6
$\begingroup$

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.

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

enter image description here

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

enter image description here

$\endgroup$
  • $\begingroup$ 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)? $\endgroup$ – Malakriss729 Jan 17 '16 at 16:46
  • $\begingroup$ @Malakriss729 so you know how many connections vertices may have and have a color for each case? $\endgroup$ – Kuba Jan 17 '16 at 16:49
  • $\begingroup$ @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. $\endgroup$ – Kuba Jan 18 '16 at 6:26
3
$\begingroup$

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

enter image description here

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

enter image description here

$\endgroup$
3
$\begingroup$

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

Delaunay mesh with points colored by valence

$\endgroup$
2
$\begingroup$

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

Delaunay mesh with colored vertices

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.

$\endgroup$
0
$\begingroup$

You can also get the number of neighbors using the "VertexVertexConnectivity" property of the mesh object:

SeedRandom[42, Method -> "Legacy"]; (* using J.M.'s example*)
mesh = DelaunayMesh[RandomReal[10, {30, 2}]];

vd = Length/@ mesh["VertexVertexConnectivity"];
mcstyles = MapIndexed[{0,#2[[1]]} -> Directive[{PointSize[#/200], ColorData[97]@#}]&, vd];

You can then use mcstyles with MeshRegion or HighlightMesh:

MeshRegion[mesh, MeshCellStyle -> mcstyles]

or

HighlightMesh[mesh, Style @@@ mcstyles]

Mathematica graphics

Or add a legend as in J.M.'s answer:

Legended[MeshRegion[mesh,  MeshCellStyle ->  mcstyles],  
  SwatchLegend[ColorData[97]/@ #, #]& @ Union[vd]]

Mathematica graphics

$\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.