5
$\begingroup$

Let consider the network ('graph'):

q1 = {{6545, 1044}, {6546, 1044}, {6536, 1044}, {6537, 1043}, {6529, 
1044}, {6530, 1043}, {6528, 1044}, {6529, 1044}, {6528, 
1044}, {6529, 1043}, {6527, 1044}, {6528, 1044}, {6522, 
1044}, {6523, 1043}, {6544, 1045}, {6545, 1044}, {6535, 
1045}, {6536, 1044}, {6526, 1045}, {6527, 1044}, {6521, 
1045}, {6522, 1044}, {6543, 1046}, {6544, 1045}, {6534, 
1046}, {6535, 1045}, {6525, 1046}, {6526, 1045}, {6521, 
1046}, {6522, 1045}, {6520, 1046}, {6521, 1045}, {6517, 
1046}, {6518, 1047}, {6542, 1047}, {6543, 1048}, {6542, 
1047}, {6543, 1046}, {6535, 1047}, {6536, 1046}, {6534, 
1047}, {6535, 1047}, {6533, 1047}, {6534, 1047}, {6533, 
1047}, {6534, 1046}, {6532, 1047}, {6533, 1047}, {6531, 
1047}, {6532, 1047}, {6525, 1047}, {6526, 1048}, {6524, 
1047}, {6525, 1047}, {6524, 1047}, {6525, 1046}, {6520, 
1047}, {6521, 1046}, {6519, 1047}, {6520, 1047}, {6519, 
1047}, {6520, 1046}, {6518, 1047}, {6519, 1047}, {6518, 
1047}, {6518, 1048}, {6549, 1048}, {6550, 1049}, {6543, 
1048}, {6544, 1049}, {6532, 1048}, {6533, 1049}, {6532, 
1048}, {6533, 1047}, {6530, 1048}, {6531, 1047}, {6526, 
1048}, {6527, 1049}, {6523, 1048}, {6524, 1047}, {6518, 
1048}, {6518, 1049}, {6550, 1049}, {6551, 1050}, {6548, 
1049}, {6549, 1048}, {6547, 1049}, {6548, 1049}, {6545, 
1049}, {6546, 1050}, {6544, 1049}, {6545, 1049}, {6543, 
1049}, {6544, 1049}, {6542, 1049}, {6543, 1049}, {6539, 
1049}, {6540, 1050}, {6538, 1049}, {6539, 1049}, {6537, 
1049}, {6538, 1049}, {6536, 1049}, {6537, 1049}, {6533, 
1049}, {6534, 1050}, {6529, 1049}, {6530, 1048}, {6529, 
1049}, {6529, 1050}, {6527, 1049}, {6528, 1050}, {6522, 
1049}, {6523, 1048}, {6518, 1049}, {6519, 1050}, {6518, 
1049}, {6518, 1050}, {6551, 1050}, {6551, 1051}, {6546, 
1050}, {6547, 1049}, {6543, 1050}, {6544, 1049}, {6541, 
1050}, {6542, 1049}, {6540, 1050}, {6541, 1050}, {6535, 
1050}, {6536, 1049}, {6534, 1050}, {6535, 1050}, {6529, 
1050}, {6529, 1051}, {6528, 1050}, {6529, 1051}, {6521, 
1050}, {6522, 1049}, {6519, 1050}, {6520, 1051}, {6551, 
1051}, {6551, 1052}, {6542, 1051}, {6543, 1050}, {6529, 
1051}, {6529, 1052}, {6520, 1051}, {6521, 1052}, {6520, 
1051}, {6521, 1050}, {6517, 1051}, {6518, 1050}, {6551, 
1052}, {6552, 1052}, {6541, 1052}, {6542, 1051}, {6529, 
1052}, {6530, 1053}, {6521, 1052}, {6522, 1053}, {6540, 
1053}, {6541, 1052}, {6538, 1053}, {6539, 1054}, {6531, 
1053}, {6532, 1054}, {6530, 1053}, {6531, 1054}, {6530, 
1053}, {6531, 1053}, {6522, 1053}, {6522, 1054}, {6539, 
1054}, {6540, 1053}, {6531, 1054}, {6532, 1055}, {6533, 
1055}, {6534, 1054}, {6532, 1055}, {6533, 1056}, {6532, 
1055}, {6533, 1055}, {6521, 1055}, {6522, 1054}, {6533, 
1056}, {6533, 1057}, {6520, 1056}, {6521, 1055}, {6534, 
1057}, {6535, 1056}, {6533, 1057}, {6534, 1057}, {6519, 
1057}, {6520, 1056}, {6518, 1058}, {6519, 1057}, {6517, 
1059}, {6518, 1058}};
q2 = Partition[q1, 2];
q3 = Map[Line@# &, q2];
lines = Graphics[{Red, Thick, Opacity[0.7], q3}, ImageSize -> 500];
k2 = ListPlot[Take[q1], PlotStyle -> Black];
graph = Show[lines, k2]

enter image description here

Let's draw a node:

pointX = RandomChoice[q1];

Let `pointX = {6534, 1050};

How to find specific graph nodes at distance 'r'?

Searched nodes have a degree greater than 2.

An example for 'r1=8' and 'r=4' is shown below: enter image description here

We are only looking for the number of these points!

You can see that:

  • There are 4 such points at a distance of 'r1'.

  • There is 1 such point at a distance 'r2'.

$\endgroup$
4
  • 1
    $\begingroup$ Extract the coordinates (GraphEmbedding) and use Nearest? Does this work for you? $\endgroup$
    – Szabolcs
    Mar 19, 2020 at 12:28
  • $\begingroup$ 'GraphEmbedding' does not work for 'Graphics[] ', unfortunately :( $\endgroup$
    – ralph
    Mar 19, 2020 at 13:34
  • $\begingroup$ In addition, the conversion to the graph will change its topology (shape). $\endgroup$
    – ralph
    Mar 19, 2020 at 13:42
  • $\begingroup$ @ralph just use region intersection on disk and points $\endgroup$
    – user5601
    Mar 19, 2020 at 18:38

3 Answers 3

7
$\begingroup$

kglr's answer is great (especially the Manipulate!), but this problem gives me a chance to show off a couple under-appreciated Mathematica functions I really like, so I'll take a crack at it too.

First, let's do the work necessary to actually turn this into a Mathematica Graph object. We need to start with a list of unique points.

points = DeleteDuplicates[q1];

It will be convenient to refer to them by an index, which PositionIndex is almost perfect for. However, it returns a bunch of singleton lists, while we want integers.

pointIndex = First /@ PositionIndex[points];

Going the other way will also help!

vertexCoordinates = AssociationMap[Reverse, pointIndex];

With pointIndex, we can easily construct a list of edges using BlockMap; no need for an extra Partition step:

edges = BlockMap[Apply[UndirectedEdge], pointIndex /@ q1, 2];

Now we can represent the graph as a, well, graph instead of just a collection of lines:

graph = Graph[edges, VertexCoordinates -> Normal@vertexCoordinates]

graph

Let's find all the high degree vertices:

degree = AssociationThread[VertexList[graph] -> VertexDegree[graph]];

highDegree = Keys@Select[degree, GreaterThan[2]];

Now, we need a function that will tell us how many points are given to any other point, and the one-argument from of Nearest is just the thing:

nearest = Nearest[Normal@pointIndex]; 
within = (Curry[nearest][{All, #}]@*vertexCoordinates) &

Now let's choose a point:

RandomSeed[1337];
point = RandomChoice@pointIndex
(* 89 *)

Now we can find the nodes that are within a given radius of point and have degree greater than 2 with just an Intersection:

radius = 8;
qualifying = Intersection[highDegree, within[radius][point]]
(* {70, 80, 89} *)

Now we can show our points on the graph:

Show[
 HighlightGraph[graph, 
  Append[Thread[Style[qualifying, Green]], Style[point, Red]], 
  VertexSize -> Large],
 Graphics[{Dashed, Circle[vertexCoordinates@point, radius]}],
 PlotRange -> (MinMax /@ Transpose[points]), 
 PlotRangePadding -> Scaled[.05]]

highlighted

Update #1

While this works fine for a small dataset, apparently Graph is a huge bottleneck for larger datasets like the one linked in the comments below. Happily for us, that step isn't really necessary, since we only need to compute the degree of each vertex, and that's very easy.

My first attempt constructed edges in exactly the same way, and then uses CountsBy twice to find the number of times that each point appears in either the first or second position in an edge:

degree = Merge[{CountsBy[edges, First], CountsBy[edges, Last]}, Total]; // AbsoluteTiming
(* {9.50316, Null} *)

Ten seconds ain't bad, but there's an even easier and faster solution because the degree of a vertex is just the number of times it appears in the original q1. Since using Lookup to do a big batch of lookups in an association is faster than mapping it, I was able to get the time required to compute degree down to two seconds (and skip the step where we construct edges entirely, which took a couple more seconds).

degree = Counts[Lookup[pointIndex, data]]; // AbsoluteTiming
(* {2.07044, Null} *)

On my computer the whole computation was finished in under a minute, with about half the time taken up with the file import.

It's weird Graph is so dang slow, though.

Update #2

It turns out that it's passing the VertexCoordinates option that slows things down so much. Without that, it only takes about a second!

graph = Graph[edges]; // AbsoluteTiming
(* {1.12316, Null} *)

If I had to speculate, that option forces the routine to do some sort of layout or rendering that's very slow for largish numbers of points.

Update 3

The issue is not VertexCoordinates, it's passing a list of rules as the argument. If you do an ordered list of points, it's much faster, suggesting that the current version uses rule replacement to assign the coordinates to each point in turn:

graph = Graph[edges, VertexCoordinates -> Values@coordinateIndex]; // AbsoluteTiming

Alternatively, it turns out you can pass in a Dispatched list of rules (or association) and get good performance.

coordinateDispatch = Dispatch@coordinateIndex; // AbsoluteTiming
(* {1.12082, Null} *)

graph = Graph[edges, VertexCoordinates -> coordinateDispatch]; // AbsoluteTiming
(* {2.86843, Null} *)
$\endgroup$
6
  • $\begingroup$ Thanks! Where is 'coordinateIndex' defined? $\endgroup$
    – ralph
    Mar 20, 2020 at 19:27
  • $\begingroup$ Copied the wrong cell. Fixed. $\endgroup$
    – Pillsy
    Mar 20, 2020 at 22:42
  • $\begingroup$ How to replace the command "Curry[]"? I have Mathematica v11. $\endgroup$
    – ralph
    Mar 21, 2020 at 8:18
  • $\begingroup$ You can define your own as Curry[f_][y_][x_] := f[x, y]. $\endgroup$
    – Pillsy
    Mar 21, 2020 at 16:28
  • $\begingroup$ Thank you very much, again. But for a big network, the script has 'a bottleneck', ie Graph []. Details here: drive.google.com/drive/folders/… $\endgroup$
    – ralph
    Mar 22, 2020 at 8:41
5
$\begingroup$

Update: Using locators to specify a radius for each selected node:

qToV = AssociationThread[#, Range@Length @ #] & @ DeleteDuplicates[q1];
vToQ = Association @ KeyValueMap[#2 -> # &]@qToV;
vl = Values @ qToV;
el = UndirectedEdge @@@ Partition[qToV /@ q1, 2];
gr = Graph[vl, el, VertexCoordinates -> Normal[vToQ], 
   VertexShapeFunction -> "Point", EdgeStyle -> Red, 
   VertexStyle -> Black, ImageSize -> Large];
vdGT2 = Select[VertexDegree[gr, #] > 2 &] @ vl;

Manipulate[Dynamic @ HighlightGraph[gr, 
   Join @@ {Function[c, 
       Style[Select[Norm[vToQ@c - vToQ@#] <= Norm[vToQ@c - locs[[c]]] &]@vdGT2, 
          Directive[AbsolutePointSize[7], Opacity[1], Green]]] /@ centers, 
       Style[#, Directive[AbsolutePointSize[8], Opacity[1], Purple]] & /@ centers}, 
   Prolog -> {Green, Dashed, Circle[vToQ[#], Norm[vToQ@# - locs[[#]]]] & /@ centers, 
     Text[Style["◼", show /. {True -> Orange, False -> White}, 
         FontSize -> show /. {True -> 14, False -> 1}], #] & /@ locs[[centers]]}, 
   ImagePadding -> 50, PlotRangeClipping -> False], 
 Dynamic @ Row[{Control@{{centers, {10, 43}}, vl, TogglerBar, 
      Appearance -> "Horizontal" -> {5, Automatic}}, 
    If[CurrentValue["MouseOver"], 
     Control[{{show, True, ""}, {True -> "Hide Locators", 
        False -> "Show Locators"}, ControlType -> Toggler, 
       Background -> Lighter[Gray, 0.5], FrameMargins -> 10}], ""]}, 
   Spacer[5]], 
 {{locs, 2 {Cos[Pi/4], Sin[Pi/4]} + # & /@ DeleteDuplicates[q1]}, Locator, 
  Appearance -> None}, 
 Alignment -> Center]

enter image description here

enter image description here

Original answer:

qToV = AssociationThread[#, Range@Length@#] &@DeleteDuplicates[q1];
vToQ = Association@KeyValueMap[#2 -> # &]@qToV;
vl = Values @ qToV;
el = UndirectedEdge @@@ Partition[qToV /@ q1, 2];
gr = Graph[vl, el, VertexCoordinates -> Normal[vToQ], 
   VertexShapeFunction -> "Point", EdgeStyle -> Red, 
   VertexStyle -> Black, ImageSize -> Large];
vdGT2 = Select[VertexDegree[gr, #] > 2 &] @ vl;

Manipulate[HighlightGraph[gr, 
   {Style[Select[Norm[vToQ@center - vToQ@#] <= radii[[1]] &] @ vdGT2,
      Directive[AbsolutePointSize[10], Opacity[1], Blue]],
    Style[Select[radii[[1]] <= Norm[vToQ@center - vToQ@#] <= radii[[2]] &]@vdGT2,
      Directive[AbsolutePointSize[10], Opacity[1], Green]],
    Style[center, Directive[AbsolutePointSize[10], Opacity[1], Purple]]}, 
   Prolog -> {FaceForm[], 
     EdgeForm[{Blue, Dashed}], Disk[vToQ[center], radii[[1]]],
     EdgeForm[{Green, Dashed}], Disk[vToQ[center], radii[[2]]]},
   ImagePadding -> 50, PlotRangeClipping -> False],
 {{center, 10}, vl, SetterBar, Appearance -> "Horizontal" -> {5, Automatic}},
 {{radii, {4, 8}}, 0, 20, IntervalSlider[##, Method -> "Stop"] &,
    Appearance -> {"Paired", "Labeled"}, ImageSize -> 350},
 Alignment -> Center, TrackedSymbols :> {center, radii}]

enter image description here

$\endgroup$
1
  • $\begingroup$ Thank you very much. What 'vToCoords' is? Calculations will be made for very large networks. This was just an example. There will be a definite set points 'points = RandomSample[q1, Floor[Length[q1]/10]]'. For each of these 'points' the number of 'specific nodes(degree greater than 2)' should be determined for e.g. r = {1,2,3,4,5, ...., 30}. $\endgroup$
    – ralph
    Mar 20, 2020 at 10:55
-1
$\begingroup$

Thank you all for your help and comments!

I think I found a very fast and simple 'script':

q1=Partition[q1, 2];

q2 = Map[Line@# &, q1];

pointX = {6534, 1050}; (example)

R = 12; (example)

k1 = Graphics[{Green, Thick, Dashed, Circle[pointX, R]}];

k2 = ListPlot[{pointX}, PlotStyle -> {Thick, Green, PointSize[.025]}];

k3 = ListPlot[Flatten[q1, 1], PlotStyle -> Black];

lines = Graphics[{Red, Thick, Opacity[0.7], q2}, ImageSize -> 500];

k6 = Show[lines, k1, k2, k3]

q3 = Select[ q1, ((#[[1, 1]] - pointX[[1]])^2 + (#[[1, 2]] - pointX[[2]])^2 <= (R)^2) &];

q4 = Select[ q3, ((#[[2, 1]] - pointX[[1]])^2 + (#[[2, 2]] - pointX[[2]])^2 <= (R)^2) &];

q88 = Map[Line@# &, q4];

k7 = Graphics[{Blue, Thick, Opacity[0.7], q88}, ImageSize -> 500];

k8 = Show[k6, k7]

q5 = Split[Sort[Flatten[q4, 1]]];

q6 = Select[q5, Length[#] >= 3 &];

k9 = ListPlot[q6[[All, 1]], PlotStyle -> {Thick, Red, PointSize[.025]}];

Show[k8, k9]

Print["Solution -> ", Length@q6] (Solution !!!!!!!!)

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.