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.

|improve this question
$\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

|improve this answer
$\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

|improve this answer
$\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

|improve this answer
$\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.

|improve this answer
$\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

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