# Speed up honeycomb display in a Manipulate expression

I have a square area with a background hexagonal tiling. When I click on a certain point of the area I want the hexagon placed there to show/hide. I've implemented it as follows:

1. Calculate hexagon-center points (vert1, vert2, centerPoints)
2. Calculate vertices of each hexagon (vertices)
3. Create hexagons using the vertices (polygons)
4. ClickPane&Graphics. On click:
i.$\$ Check in what polygon is the clicked point (using Element)
ii. Add or remove it from a list with visible hexagons (activeHexagons)

Manipulate[
(*Center Points*)
vert1 = Table[
r*{3 x, Sqrt y}, {x, 0, Ceiling[a/(3 r)]}, {y, 0,
Ceiling[b/(Sqrt*r)]}];
vert2 = Map[# + {3/2, Sqrt/2}*r &, vert1, {2}];
centerPoints = Flatten[Join[vert1, vert2], 1];
vertices =
ConstantArray[#, 7] +
r*Table[{Cos[θ], Sin[θ]}, {θ, 0,
2 π, π/3}] & /@ centerPoints;
polygons = Polygon /@ vertices[[All, 1 ;; 6]];
DynamicModule[{activeHexagons = {},
clickedHexagon,
pt},
ClickPane[Framed @ Show[
Graphics[Dynamic@(Line /@ vertices[[activeHexagons]]),
PlotRange -> {{0, a}, {0, b}}, AspectRatio -> Automatic],
Graphics[Dynamic@(Point /@ centerPoints[[activeHexagons]])]
],
(pt = #;
clickedHexagon =
Flatten[Position[Element[pt, #] & /@ polygons, True]][];
activeHexagons = If[
MemberQ[activeHexagons, clickedHexagon],
DeleteCases[activeHexagons, clickedHexagon],
AppendTo[activeHexagons, clickedHexagon]]) &]],
{{a, 7, "Honeycomb width"}, 2, 8},
{{b, 7, "Honeycomb height"}, 2, 8},
{{r, 0.2, "Hexagon radius"}, 0.1, 3}]


For areas with many hexagons my code is really slow (with default manipulate parameters >2s delay between mouse-click and displaying the hexagon). How can I make it faster?

(For now resizing the area/hexagon size with Manipulate changes the relative position of the hexagons. Keeping the relative position would be nicer but isn't really important)

Bottleneck here is the part clickedHexagon = Flatten[Position[Element[pt, #] & /@ polygons, True]]. You could use Nearest function for this.

Manipulate[(*Center Points*)
centerPoints =
Flatten[Table[{#, # + {3/2, Sqrt/2}*r} &[r*{3 x, Sqrt y}], {x,
0, Ceiling[a/(3 r)]}, {y, 0, Ceiling[b/(Sqrt*r)]}], 2];
nearPoint = Nearest[centerPoints];
DynamicModule[{activeHexagons = {}, clickedHexagon, pt},
Row@{DynamicWrapper[Spacer,
activeHexagons =
DeleteDuplicates[(nearPoint /@ activeHexagons)[[All, 1]]]],
ClickPane[
Framed@
Show[Graphics[{EdgeForm[Black], FaceForm[None],
Dynamic@{RegularPolygon[#, r, 6] & /@ activeHexagons,
Point[activeHexagons]}}, PlotRange -> {{0, a}, {0, b}},
AspectRatio -> Automatic], ImageSize -> 300], (pt = #;
clickedHexagon = First[nearPoint[pt]];
activeHexagons =
If[MemberQ[activeHexagons, clickedHexagon],
DeleteCases[activeHexagons, clickedHexagon],
AppendTo[activeHexagons, clickedHexagon]
]) &]}], {{a, 7, "Honeycomb width"}, 2,
8}, {{b, 7, "Honeycomb height"}, 2, 8}, {{r, 0.2, "Hexagon radius"},
0.1, 3}]