Return to Answer

ToPack = Developer`ToPackedArray; getPolygonPolygonAdjacencyList[R_MeshRegion] := Module[{pts, polygons, edgesfrompolygons, edges, edgelookupcontainer, polyranges, polygonsneighedges, edgepolygonadjacencymatrix, acc,ilist,jlist}, pts = MeshCoordinates[R]; polygons = ToPack[MeshCells[R, 2][[All, 1]]]; edgesfrompolygons = ToPack[Flatten[getEdgesFromPolygons[polygons], 1]]; edges = DeleteDuplicates[edgesfrompolygons]; edgelookupcontainer = SparseArray[ Rule[Join[edges, Transpose[Transpose[edges][[{2, 1}]]]], Join[Range[1, Length[edges]], Range[1, Length[edges]]]], {Length[ pts], Length[pts]}]; acc = Join[{0}, Accumulate[ToPack[Length /@ polygons]]]; polyranges = Transpose[{Most[acc] + 1, Rest[acc]}]; {ilist, jlist} = Transpose[edgesfrompolygons]; polygonsneighedges = takeSortedThread[extractIntegerFromSparseMatrix[ edgelookupcontainer["NonzeroValues"], edgelookupcontainer["RowPointers"], Flatten@edgelookupcontainer["ColumnIndices"], edgelookupcontainer["Background"], edgesfrompolygons[[All, 1]], edgesfrompolygons[[All, 2]]], polyranges]; edgepolygonadjacencymatrix = Transpose@With[{ n = Length[edges], m = Length[polygons], data = ToPack[Flatten[polygonsneighedges]] }, SparseArray @@ {Automatic, {m, n}, 0, {1, {acc, Transpose[{data}]}, ConstantArray[1, Length[data]]}} ]; Select[(edgepolygonadjacencymatrix["AdjacencyLists"]), Length[#] == 2 &] ] 

ToPack = Developer`ToPackedArray; getPolygonPolygonAdjacencyList[R_MeshRegion] := Module[{pts, polygons, edgesfrompolygons, edges, edgelookupcontainer, polyranges, polygonsneighedges, edgepolygonadjacencymatrix, acc}, pts = MeshCoordinates[R]; polygons = ToPack[MeshCells[R, 2][[All, 1]]]; edgesfrompolygons = ToPack[Flatten[getEdgesFromPolygons[polygons], 1]]; edges = DeleteDuplicates[edgesfrompolygons]; edgelookupcontainer = SparseArray[ Rule[Join[edges, Transpose[Transpose[edges][[{2, 1}]]]], Join[Range[1, Length[edges]], Range[1, Length[edges]]]], {Length[ pts], Length[pts]}]; acc = Join[{0}, Accumulate[ToPack[Length /@ polygons]]]; polyranges = Transpose[{Most[acc] + 1, Rest[acc]}]; polygonsneighedges = takeSortedThread[extractIntegerFromSparseMatrix[ edgelookupcontainer["NonzeroValues"], edgelookupcontainer["RowPointers"], Flatten@edgelookupcontainer["ColumnIndices"], edgelookupcontainer["Background"], edgesfrompolygons[[All, 1]], edgesfrompolygons[[All, 2]]], polyranges]; edgepolygonadjacencymatrix = Transpose@With[{ n = Length[edges], m = Length[polygons], data = ToPack[Flatten[polygonsneighedges]] }, SparseArray @@ {Automatic, {m, n}, 0, {1, {acc, Transpose[{data}]}, ConstantArray[1, Length[data]]}} ]; Select[(edgepolygonadjacencymatrix["AdjacencyLists"]), Length[#] == 2 &] ] 

I need two compiled helper functions:

getEdgesFromPolygons = Compile[{{f, _Integer, 1}}, Table[ { Min[Compile`GetElement[f, i], Compile`GetElement[f, Mod[i + 1, Length[f], 1]]], Max[Compile`GetElement[f, i], Compile`GetElement[f, Mod[i + 1, Length[f], 1]]] }, {i, 1, Length[f]} ], RuntimeAttributes -> {Listable}, Parallelization -> True, CompilationTarget -> "C" ]; takeSortedThread = Compile[{{data, _Integer, 1}, {ran, _Integer, 1}}, Sort[Part[data, ran[[1]] ;; ran[[2]]]], RuntimeAttributes -> {Listable}, Parallelization -> True, CompilationTarget -> "C" ]; 

ToPack = Developer`ToPackedArray; getPolygonPolygonAdjacencyList[R_MeshRegion] := Module[{pts, polygons, edgesfrompolygons, edges, edgelookupcontainer, polyranges, polygonsneighedges, edgepolygonadjacencymatrix, acc}, pts = MeshCoordinates[R]; polygons = ToPack[MeshCells[R, 2][[All, 1]]]; edgesfrompolygons = ToPack[Flatten[getEdgesFromPolygons[polygons], 1]]; edges = DeleteDuplicates[edgesfrompolygons]; edgelookupcontainer = SparseArray[ Rule[Join[edges, Transpose[Transpose[edges][[{2, 1}]]]], Join[Range[1, Length[edges]], Range[1, Length[edges]]]], {Length[ pts], Length[pts]}]; acc = Join[{0}, Accumulate[ToPack[Length /@ polygons]]]; polyranges = Transpose[{Most[acc] + 1, Rest[acc]}]; polygonsneighedges = takeSortedThread[Extract[edgelookupcontainer, edgesfrompolygons], polyranges]; edgepolygonadjacencymatrix = Transpose@With[{ n = Length[edges], m = Length[polygons], data = ToPack[Flatten[polygonsneighedges]] }, SparseArray @@ {Automatic, {m, n}, 0, {1, {acc, Transpose[{data}]}, ConstantArray[1, Length[data]]}} ]; Select[(edgepolygonadjacencymatrix["AdjacencyLists"]), Length[#] == 2 &] ] 

SeedRandom[123] pts = RandomReal[1, {10000, 2}]; R = VoronoiMesh[pts, MeshCellLabel -> {2 -> "Index"}]; // AbsoluteTiming getPolygonPolygonAdjacencyList[R]; // AbsoluteTiming 

{0.642147, Null}

{0.093132, Null}

Slight improvement by merging Sort into takeThread (takeThread replaced by takeSortedThread).

I need three compiled helper functions:

getEdgesFromPolygons = Compile[{{f, _Integer, 1}}, Table[ { Min[Compile`GetElement[f, i], Compile`GetElement[f, Mod[i + 1, Length[f], 1]]], Max[Compile`GetElement[f, i], Compile`GetElement[f, Mod[i + 1, Length[f], 1]]] }, {i, 1, Length[f]} ], RuntimeAttributes -> {Listable}, Parallelization -> True, CompilationTarget -> "C" ]; takeSortedThread = Compile[{{data, _Integer, 1}, {ran, _Integer, 1}}, Sort[Part[data, ran[[1]] ;; ran[[2]]]], RuntimeAttributes -> {Listable}, Parallelization -> True, CompilationTarget -> "C" ]; extractIntegerFromSparseMatrix = Compile[ {{vals, _Integer, 1}, {rp, _Integer, 1}, {ci, _Integer, 1}, {background, _Integer}, {i, _Integer}, {j, _Integer}}, Block[{k}, k = rp[[i]] + 1; While[k < rp[[i + 1]] + 1 && ci[[k]] != j, ++k];   If[k == rp[[i + 1]] + 1, background, vals[[k]]] ], RuntimeAttributes -> {Listable}, Parallelization -> True, CompilationTarget -> "C" ]; 

ToPack = Developer`ToPackedArray; getPolygonPolygonAdjacencyList[R_MeshRegion] := Module[{pts, polygons, edgesfrompolygons, edges, edgelookupcontainer, polyranges, polygonsneighedges, edgepolygonadjacencymatrix, acc,ilist,jlist}, pts = MeshCoordinates[R]; polygons = ToPack[MeshCells[R, 2][[All, 1]]]; edgesfrompolygons = ToPack[Flatten[getEdgesFromPolygons[polygons], 1]]; edges = DeleteDuplicates[edgesfrompolygons]; edgelookupcontainer = SparseArray[ Rule[Join[edges, Transpose[Transpose[edges][[{2, 1}]]]], Join[Range[1, Length[edges]], Range[1, Length[edges]]]], {Length[ pts], Length[pts]}]; acc = Join[{0}, Accumulate[ToPack[Length /@ polygons]]]; polyranges = Transpose[{Most[acc] + 1, Rest[acc]}]; {ilist, jlist} = Transpose[edgesfrompolygons]; polygonsneighedges = takeSortedThread[extractIntegerFromSparseMatrix[  edgelookupcontainer["NonzeroValues"],    edgelookupcontainer["RowPointers"], Flatten@edgelookupcontainer["ColumnIndices"], edgelookupcontainer["Background"], edgesfrompolygons[[All, 1]], edgesfrompolygons[[All, 2]]],   polyranges]; edgepolygonadjacencymatrix = Transpose@With[{ n = Length[edges], m = Length[polygons], data = ToPack[Flatten[polygonsneighedges]] }, SparseArray @@ {Automatic, {m, n}, 0, {1, {acc, Transpose[{data}]}, ConstantArray[1, Length[data]]}} ]; Select[(edgepolygonadjacencymatrix["AdjacencyLists"]), Length[#] == 2 &] ] 

SeedRandom[123] pts = RandomReal[1, {10000, 2}]; R = VoronoiMesh[pts,  MeshCellLabel -> {2 -> "Index"}]; // RepeatedTiming getPolygonPolygonAdjacencyList[R]; // RepeatedTiming 

{0.625, Null}

{0.086, Null}

Slight improvement by merging Sort into takeThread (takeThread replaced by takeSortedThread).

Slight improvement by replacing Extract with extractIntegerFromSparseMatrix.

getEdgesFromPolygons = Compile[{{f, _Integer, 1}}, Table[ { Min[Compile`GetElement[f, i], Compile`GetElement[f, Mod[i + 1, Length[f], 1]]], Max[Compile`GetElement[f, i], Compile`GetElement[f, Mod[i + 1, Length[f], 1]]] }, {i, 1, Length[f]} ], RuntimeAttributes -> {Listable}, Parallelization -> True, CompilationTarget -> "C" ]; takeThread = Compile[{{data, _Integer, 1}, {ran, _Integer, 1}}, Part[data, ran[[1]] ;; ran[[2]]], RuntimeAttributes -> {Listable}, Parallelization -> True, CompilationTarget -> "C" ]; 

ToPack = Developer`ToPackedArray; getPolygonPolygonAdjacencyList[R_MeshRegion] := Module[{pts, polygons, edgesfrompolygons, edges, edgelookupcontainer, polyranges, polygonsneighedges, edgepolygonadjacencymatrix, acc}, pts = MeshCoordinates[R]; polygons = ToPack[MeshCells[R, 2][[All, 1]]]; edgesfrompolygons = ToPack[Flatten[getEdgesFromPolygons[polygons], 1]]; edges = DeleteDuplicates[edgesfrompolygons]; edgelookupcontainer = SparseArray[ Rule[Join[edges, Transpose[Transpose[edges][[{2, 1}]]]], Join[Range[1, Length[edges]], Range[1, Length[edges]]]], {Length[ pts], Length[pts]}]; acc = Join[{0}, Accumulate[ToPack[Length /@ polygons]]]; polyranges = Transpose[{Most[acc] + 1, Rest[acc]}]; polygonsneighedges = takeThread[Extract[edgelookupcontainer, edgesfrompolygons], polyranges]; edgepolygonadjacencymatrix = Transpose@With[{ n = Length[edges], m = Length[polygons], data = ToPack[Flatten[Sort[#] & /@ polygonsneighedges]] }, SparseArray @@ {Automatic, {m, n}, 0, {1, {acc, Transpose[{data}]}, ConstantArray[1, Length[data]]}} ]; Select[(edgepolygonadjacencymatrix["AdjacencyLists"]), Length[#] == 2 &] ] 

{0.636762, Null}

{0.105823, Null}

getEdgesFromPolygons = Compile[{{f, _Integer, 1}}, Table[ { Min[Compile`GetElement[f, i], Compile`GetElement[f, Mod[i + 1, Length[f], 1]]], Max[Compile`GetElement[f, i], Compile`GetElement[f, Mod[i + 1, Length[f], 1]]] }, {i, 1, Length[f]} ], RuntimeAttributes -> {Listable}, Parallelization -> True, CompilationTarget -> "C" ]; takeSortedThread = Compile[{{data, _Integer, 1}, {ran, _Integer, 1}}, Sort[Part[data, ran[[1]] ;; ran[[2]]]], RuntimeAttributes -> {Listable}, Parallelization -> True, CompilationTarget -> "C" ]; 

ToPack = Developer`ToPackedArray; getPolygonPolygonAdjacencyList[R_MeshRegion] := Module[{pts, polygons, edgesfrompolygons, edges, edgelookupcontainer, polyranges, polygonsneighedges, edgepolygonadjacencymatrix, acc}, pts = MeshCoordinates[R]; polygons = ToPack[MeshCells[R, 2][[All, 1]]]; edgesfrompolygons = ToPack[Flatten[getEdgesFromPolygons[polygons], 1]]; edges = DeleteDuplicates[edgesfrompolygons]; edgelookupcontainer = SparseArray[ Rule[Join[edges, Transpose[Transpose[edges][[{2, 1}]]]], Join[Range[1, Length[edges]], Range[1, Length[edges]]]], {Length[ pts], Length[pts]}]; acc = Join[{0}, Accumulate[ToPack[Length /@ polygons]]]; polyranges = Transpose[{Most[acc] + 1, Rest[acc]}]; polygonsneighedges = takeSortedThread[Extract[edgelookupcontainer, edgesfrompolygons], polyranges]; edgepolygonadjacencymatrix = Transpose@With[{ n = Length[edges], m = Length[polygons], data = ToPack[Flatten[polygonsneighedges]] }, SparseArray @@ {Automatic, {m, n}, 0, {1, {acc, Transpose[{data}]}, ConstantArray[1, Length[data]]}} ]; Select[(edgepolygonadjacencymatrix["AdjacencyLists"]), Length[#] == 2 &] ] 

{0.642147, Null}

{0.093132, Null}

Edit

Slight improvement by merging Sort into takeThread (takeThread replaced by takeSortedThread).