Colouring points in a Delaunay Mesh by the number of nearest neighbours

Question

I apologise if this is a repeated question, but I've searched for a while and can't find anything.

I'm doing some molecular dynamics simulations using Mathematica 10, and I've placed a DelaunayMesh over the points. I'd like the points to be coloured according to the number of nearest neighbours the mesh finds; i.e. those connecting to six other points being of one colour, but those connecting to five a different colour etc.

Is there a way to do this? Thanks in advance.

Answer 1

mesh = DelaunayMesh[RandomReal[10, {30, 2}]];
counts = Counts @ Flatten @ MeshCells[mesh, 1][[All, 1]]
    (*normalization of counts*)
counts = Rescale[#, MinMax @ counts] & /@ counts

HighlightMesh[
 mesh,
 KeyValueMap[
    Style[{0, #}, Directive[PointSize[#2/10], Blend["TemperatureMap", #2]]] &, 
    counts
 ]
]

Answer 2

A solution with MeshCellStyle:

mesh = DelaunayMesh@RandomReal[{-1, 1}, {50, 2}];
neighborsNumber[meshLines_, pointIndex_] := Length@Select[
   meshLines[[All, 1]],
   #[[1]] == pointIndex || #[[2]] == pointIndex &
   ]
With[{
  meshCoords = MeshCoordinates[mesh],
  meshLines = MeshCells[mesh, 1]
  },
 With[{
   neighborsNumbers = 
    neighborsNumber[meshLines, #] & /@ Range@Length@meshCoords
   },
  MeshRegion[
   meshCoords,
   meshLines,
   MeshCellStyle -> (
     {0, #} -> {
         PointSize@0.02,
         ColorData[{"Rainbow", MinMax@neighborsNumbers}]@
          neighborsNumbers[[#]]
         } &
      /@ Range@Length@meshCoords
     )
   ]
  ]
 ]

or, to preserve the original style,

mesh = DelaunayMesh@RandomReal[{-1, 1}, {50, 2}];
neighborsNumber[meshLines_, pointIndex_] := Length@Select[
   meshLines[[All, 1]],
   #[[1]] == pointIndex || #[[2]] == pointIndex &
   ]
With[{
  meshCoords = MeshCoordinates[mesh],
  meshLines = MeshCells[mesh, 1]
  },
 With[{
   neighborsNumbers = 
    neighborsNumber[meshLines, #] & /@ Range@Length@meshCoords
   },
  MeshRegion[
   meshCoords,
   MeshCells[mesh, 2],
   MeshCellStyle -> (
     {0, #} -> {
         PointSize@0.02,
         ColorData[{"Rainbow", MinMax@neighborsNumbers}]@
          neighborsNumbers[[#]]
         } &
      /@ Range@Length@meshCoords
     )
   ]
  ]
 ]

Answer 3

One can also use the built-in graph-theoretic functions for this task:

BlockRandom[SeedRandom[42, Method -> "Legacy"]; (* for reproducibility *)
            mesh = DelaunayMesh[RandomReal[10, {30, 2}]]];

vd = VertexDegree[Graph[Range[Length[MeshCoordinates[mesh]]], 
                        MeshCells[mesh, 1] /. Line[l_] :> UndirectedEdge @@ l]];

Legended[Show[mesh,
              Epilog -> {AbsolutePointSize[6], 
                         Transpose[{ColorData[97] /@ vd,
                                    Point /@ MeshCoordinates[mesh]}]}], 
         SwatchLegend @@ Transpose[Composition[Through, {ColorData[97], Identity}] /@
                                   Union[vd]]]

Answer 4

Something like this:

npoints = 30;
points = RandomReal[10, {npoints, 2}];
nconnections = 
 Length@Position[MeshCells[DelaunayMesh[points], 1][[All, 1]], #] & /@ 
  Range[npoints]
(* {5, 6, 6, 7, 5, 7, 7, 6, 6, 4, 5, 6, 5, 7, 6, 4, 5, 6, 4, 5, \
3, 6, 5, 4, 4, 6, 6, 6, 6, 6} *)

Show[DelaunayMesh[points], 
 Graphics /@ 
  Transpose[{Directive[PointSize[Large], ColorData[97][#]] & /@ 
     nconnections, Point /@ points}]
 ]

You can use any color scheme. This may need some refinement - I'm not sure if it will by default give each number a unique color.

Answer 5

SeedRandom[42, Method -> "Legacy"]; (* using J.M.'s example*)

mesh = DelaunayMesh[RandomReal[10, {30, 2}]];

MeshConnectivityGraph

mcg = MeshConnectivityGraph[mesh];

MeshRegion[mesh, 
 Epilog -> First @ Show @
    Graph[ mcg, VertexSize -> {v_ :> 2 VertexDegree[mcg, v]}, 
     VertexStyle -> {v_ :> ColorData[97]@VertexDegree[mcg, v]}]] 

Graph[mcg,
 VertexSize -> {v_:> 2 VertexDegree[mcg, v]}, 
 VertexStyle -> {v_:> ColorData[97] @ VertexDegree[mcg, v]}, 
 Prolog -> {RGBColor[2/3, 25/32, 1], MeshPrimitives[mesh, 2]}]

gives a Graph object with the same picture.

Vertex degrees from mesh Properties

We can also get vertex degrees using the mesh properties

• "Edges"
• "AdjacencyMatrix"
• "VertexVertexConnectivity"
• "SparseAdjacencyMatrix"
• "ConnectivityMatrix"

vd = VertexDegree[mcg]

{5, 7, 6, 5, 4, 8, 7, 5, 5, 3, 6, 3, 7, 4, 5, 6, 6, 6, 6, 4, 5,
 7, 7, 4, 6, 7, 6, 5, 5, 4}

vd1 = Values @ KeySort @ Counts @ Flatten @ mesh @"Edges"
vd2 = VertexDegree @ AdjacencyGraph @ mesh @"AdjacencyMatrix";
vd3 = Total[mesh @ "AdjacencyMatrix", 1];
vd4 = Length /@ mesh @ "VertexVertexConnectivity"
vd5 = Length /@ mesh["SparseAdjacencyMatrix"] @ "AdjacencyLists";
vd6 = Length /@ mesh["ConnectivityMatrix"[0, 1]] @ "AdjacencyLists";

vd == vd1 == vd2 == vd3 == vd4 == vd5 == vd6

True

MeshRegion + MeshCellStyle

Use the list vd to define vertex styles and a legend:

mcstyles = MapIndexed[{0, #2[[1]]} -> 
   Directive[{AbsolutePointSize[2 #], ColorData[97] @ #}]&, vd];

legend = SwatchLegend[ColorData[97] /@ #, #, 
 LegendMarkers -> "Bubble", LegendMarkerSize -> 2 #] & @ Union[vd];


Legended[MeshRegion[mesh, MeshCellStyle -> mcstyles], legend]

    

MeshRegion + MeshCellShapeFunction

MeshRegion[mesh, 
 MeshCellShapeFunction -> {{0, All} -> 
  ({ColorData[97]@vd[[#3[[1, 1]]]], Disk[#, Offset[vd[[#3[[1, 1]]]]]]} &)}]

MeshRegion + MeshCellLabel

MeshRegion[mesh,  ImagePadding -> 5,
 MeshCellLabel -> MapIndexed[{0, #2[[1]]} -> 
     Placed[Graphics[{EdgeForm[Gray], ColorData[97]@#, 
        Disk[{0, 0}, Offset[#]]}], {0, 0}] &, vd]]

Graph

We can create an AdjacencyGraph object using the "AdjacencyMatrix" property and use options VertexSize and VertexStyle:

ag = AdjacencyGraph@mesh@"AdjacencyMatrix";

Graph[ag, VertexCoordinates -> MeshCoordinates[mesh], 
 VertexStyle -> {v_ :> ColorData[97]@VertexDegree[ag, v]},
 VertexSize -> {v_ :> 2 VertexDegree[ag, v]},
 Prolog -> Show[mesh][[1]]]

BubbleChart

bcdata = Join[MeshCoordinates[mesh], List /@ vd, 2]; 

BubbleChart[bcdata, ColorFunction -> (ColorData[97]@#3 &), 
 ColorFunctionScaling -> False, 
 BubbleSizes -> MinMax[vd]/100, 
 Prolog -> Show[mesh][[1]], Frame -> False]