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
]
]
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]]]
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.
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
)
]
]
]
SeedRandom[42, Method -> "Legacy"]; (* using J.M.'s example*)
mesh = DelaunayMesh[RandomReal[10, {30, 2}]];
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.
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
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[mesh,
MeshCellShapeFunction -> {{0, All} ->
({ColorData[97]@vd[[#3[[1, 1]]]], Disk[#, Offset[vd[[#3[[1, 1]]]]]]} &)}]
MeshRegion[mesh, ImagePadding -> 5,
MeshCellLabel -> MapIndexed[{0, #2[[1]]} ->
Placed[Graphics[{EdgeForm[Gray], ColorData[97]@#,
Disk[{0, 0}, Offset[#]]}], {0, 0}] &, vd]]
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]]]
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]
Blendor other color functions. – Kuba Jan 18 '16 at 06:26