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

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.

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


• I've put this in and it works great, thanks :) Just one addition; the colours seem to flicker depending on the range of connections that the program finds, is there a way of changing your code so that I can specifically program 6 connections = red, 5 connections = blue, 7 connections = green (for example)? Jan 17, 2016 at 16:46
• @Malakriss729 so you know how many connections vertices may have and have a color for each case?
– Kuba
Jan 17, 2016 at 16:49
• @Malakriss729 so? p.s. my answer "flickers" because it normlizes the count value so always the min is 0 and max 1 to fit Blend or other color functions.
– Kuba
Jan 18, 2016 at 6:26

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


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, #} -> {
[email protected],
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, #} -> {
[email protected],
ColorData[{"Rainbow", MinMax@neighborsNumbers}]@
neighborsNumbers[[#]]
} &
/@ Range@Length@meshCoords
)
]
]
]


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.

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"
vd3 = Total[mesh @ "AdjacencyMatrix", 1];
vd4 = Length /@ mesh @ "VertexVertexConnectivity"
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]