improving efficiency of a code

Question

I have the code:

SquareEdges[n_Integer?Positive] := 
 Reap[Do[If[IntegerQ[Sqrt[Prime[i + 1] + Prime[j + 1]]], 
     Sow[{i, j}]], {i, n - 1}, {j, i + 1, n}]][[2, 1]]
results = {};
n = 13;
While[n < 10001, poss = SquareEdges[n];
 gr = Graph[poss, VertexLabels -> Automatic];
 numNodes = Length[Select[VertexOutDegree[gr], # < 1 &]];
 AppendTo[results, numNodes];
 n++]
Print[results]

It seems to be working quite slowly. How can I improve the speed of it?

Answer 1

In addition to what Syed already pointed out, you can speed up the search for the restricted set of edges by using a SparseArray and by using Table instead of Sow and Reap. Moreover, I suggest to employ Count because it is more idiomatic (and also a bit faster because it does not have to create sets first):

A = SparseArray[lut -> _, {1001, 1001}];
result = Table[
  Count[VertexOutDegree[Graph[A[[1 ;; n, 1 ;; n]]["NonzeroPositions"]]], 0]
  , {n, 13, 1000}];

Originally, I meant to propose

AbsoluteTiming[
 A = SparseArray[lut -> _, {1001, 1001}];
 result = Table[
   Differences[A[[1 ;; n, 1 ;; n]]["RowPointers"]]
   , {n, 13, 1000}];
 ]

which is 10 times faster (because it avoid Graph altogether). But it gives a different result if not all vertices of from 1 to n appear in loss = A[[1 ;; n, 1 ;; n]]["NonzeroPositions"]. Not sure whether you want the one or the other...

The idea is that you use A[[1 ;; n, 1 ;; n]] (or rather its symmetrization) as the adjacency matrix of an undirected graph. Then rp = A[[1 ;; n, 1 ;; n]]["RowPointers"] contains the numbers of nonzeroes per row (== number of edges a vertex is attached to). More precisely, vertex i has rp[[i+1]] - rp[[i]] neighbors.

Answer 2

Clear[SquareEdges]
SquareEdges[n_Integer?Positive] :=
 Reap[Do[If[IntegerQ[Sqrt[Prime[i + 1] + Prime[j + 1]]], 
     Sow[{i, j}, ToString@n]], {i, n - 1}, {j, i + 1, n}]][[2, 1]]

You don't have to calculate these repeatedly as every iteration adds a few more entries. The following lookup takes 5.8s on my machine.

lut = SquareEdges[1001];

Now you can lookup from this table and Sow instead of Append:

n = 13;
Reap[While[n < 1001, poss = Select[lut, Last@# <= n &];
    gr = Graph[poss(*,VertexLabels\[Rule]Automatic*)];
    Sow[Length[Select[VertexOutDegree[gr], # < 1 &]]
     ];
    n++]][[2, 1]] // AbsoluteTiming

---

Result

{3.16412, {1, 2, 2, 2, 2, 2, 3, 3, 3, 4, 4, 4, 3, 3, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 5, 4, 4, 4, 5, 5, 5, 5, 6, 6, 6, 6, 7, 7, 7, 7, 6,
6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 7, 6, 6, 6, 6, 6, 6, 8, 8, 8, 8,
8, 8, 8, 8, 9, 9, 10, 10, 10, 10, 10, 10, 8, 7, 7, 7, 7, 7, 7, 7,
7, 7, 7, 7, 7, 6, 6, 6, 7, 7, 7, 7, 8, 8, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 8, 8, 8, 8, 6, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 7, 6, 6,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 6, 6, 6, 6, 6, 6, 6,
6, 6, 6, 8, 8, 8, 8, 8, 8, 8, 8, 9, 9, 9, 9, 9, 9, 10, 10, 10, 10,
10, 10, 10, 10, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 9, 9, 9, 9, 9, 9, 9, 9, 9, 10, 10, 10, 10,
11, 11, 11, 11, 11, 11, 12, 12, 12, 11, 11, 11, 11, 11, 11, 11, 11,
11, 11, 11, 11, 11, 11, 12, 12, 11, 11, 11, 10, 10, 10, 10, 10, 10,
10, 10, 10, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 12, 12,
12, 13, 12, 10, 10, 11, 11, 11, 11, 11, 11, 11, 11, 11, 10, 10, 8,
8, 8, 8, 8, 8, 8, 8, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 8, 8, 8,
8, 8, 8, 8, 8, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 7, 7,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8,
8, 8, 8, 8, 8, 8, 8, 9, 9, 9, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
8, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 7, 7, 7, 7,
7, 7, 7, 7, 7, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 5, 5, 5, 5,
5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
8, 8, 8, 8, 8, 8, 8, 8, 8, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 10, 10, 10, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 8, 8, 8, 8,
8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
8, 8, 8, 8, 8, 8, 8, 8, 8, 9, 9, 9, 9, 9, 9, 9, 9, 9, 8, 8, 8, 8, 8,
8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 7, 7, 7, 7, 7, 7, 6, 5,
5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
5, 5, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
5, 5, 5, 5, 5, 5, 5, 5, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6,
6, 6, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
7, 7, 7, 7, 7, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 7, 7, 8, 8, 8, 8, 8, 8, 8, 8, 8,
8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
8, 8, 8, 8, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
7, 7, 7, 6, 6, 6, 6, 6, 6, 6}}