Mathematica Programming Challenge 2003

Ed Pegg and Oyvind Tafjord
Wolfram Research

The Challenge

Consider a list of n-tuples representing points in n-dimensional space. Write a function that takes the list and returns the center of each cluster of points in it. Consider a point to be in a cluster if it is less than a distance delta from some other point in the cluster.

The Details

In messy data, the vertices of an icosahedron might be defined by 12 clusters, each containing 5 closely spaced points.  For such data, it would be useful to have a FuzzyUnion function, that would analyze the 60 points and return 12 points.

For this competition, create a FuzzyUnion function that will identify and contract point clusters.  To define a cluster, let any pair of points that are closer than a given distance delta be considered connected. A cluster is then the set of all such connected points. Replace each cluster with the average of the points within the cluster.

For instance,

FuzzyUnion[{{1, 0}, {1.1, 0}, {1.2, 0}, {1.3, 0}, {1, 1}, {1, 1.1}, {2, 
          0}}, 0.15]

For testing purposes, you could for instance use the point set

Flatten[
      Table[{Cos[n Pi/3], Sin[n Pi/3]} + 
          0.02 {Random[], Random[]}, {50}, {n, 0, 5}], 1]

For judging, your function will be given various messy sets of 2D and 3D data.  Entries will be judged on criteria like speed, originality, and elegance.

The Judging

The entries were first examined on the basis of elegance, effectiveness, and general style of programming. To study the correctness and the speed of the programs, they were put through several test cases, including:

Init

spirals = {{0.`, -1.`}, {0.5`, -1.866025403784437`}, {0.5`, -1.866025403784437`}, {1.366025403784437`, -2.366025403784437`}, {1.366025403784437`, -2.366025403784437`}, {2.366025403784437`, -2.366025403784437`}, {2.366025403784437`, -2.366025403784437`}, {3.232050807568874`, -1.866025403784437`}, {3.232050807568874`, -1.866025403784437`}, {3.732050807568874`, -1.`}, {3.732050807568874`, -1.`}, {3.732050807568874`, 
            0.`}, {3.732050807568874`, 0.`}, {3.732050807568874`, 
            1.`}, {-1.`, 3.732050807568874`}, {-1.866025403784441`, 
            3.232050807568874`}, {0.`, 3.732050807568874`}, {-1.`, 
            3.732050807568874`}, {0.8660254037844339`, 
            3.232050807568874`}, {0.`, 
            3.732050807568874`}, {1.366025403784433`, 
            2.366025403784441`}, {0.8660254037844339`, 
            3.232050807568874`}, {1.366025403784433`, 
            1.366025403784441`}, {1.366025403784433`, 
            2.366025403784441`}, {0.8660254037844339`, 
            0.5`}, {1.366025403784433`, 
            1.366025403784441`}, {-1.866025403784441`, 
            3.232050807568874`}, {-2.732050807568882`, 
            2.732050807568874`}, {-2.732050807568874`, -2.732050807568871`}, {-1.866025403784441`, -3.232050807568874`}, {-3.232050807568874`, -1.866025403784433`}, {-2.732050807568874`, -2.732050807568871`}, {-3.232050807568873`, -0.8660254037844339`}, {-3.232050807568874`, -1.866025403784433`}, {-2.732050807568874`, 
            0.`}, {-3.232050807568873`, -0.8660254037844339`}, {-1.866025403784433`, 0.5`}, {-2.732050807568874`, 
            0.`}, {-0.8660254037844374`, 
            0.5000000000000036`}, {-1.866025403784433`, 
            0.5`}, {-1.866025403784441`, -3.232050807568874`}, {-1.`, -3.732050807568874`}, {3.732050807568874`, 
            1.`}, {3.232050807568874`, 
            1.866025403784437`}, {3.232050807568874`, 
            1.866025403784437`}, {2.732050807568874`, 
            2.732050807568874`}, {2.732050807568874`, 
            2.732050807568874`}, {2.232050807568874`, 
            3.598076211353312`}, {2.232050807568874`, 
            3.598076211353312`}, {1.732050807568874`, 
            4.464101615137749`}, {1.732050807568874`, 
            4.464101615137749`}, {0.8660254037844374`, 
            4.964101615137749`}, {0.8660254037844374`, 
            4.964101615137749`}, {-0.1339745962155625`, 
            4.964101615137749`}, {-0.1339745962155625`, 
            4.964101615137749`}, {-1.133974596215562`, 
            4.964101615137749`}, {-1.133974596215562`, 
            4.964101615137749`}, {-2.`, 4.464101615137749`}, {-2.`, 
            4.464101615137749`}, {-2.866025403784439`, 
            3.964101615137749`}, {-2.866025403784439`, 
            3.964101615137749`}, {-3.732050807568878`, 
            3.464101615137749`}, {-3.732050807568878`, 
            3.464101615137749`}, {-4.232050807568878`, 
            2.598076211353312`}, {-3.732050807568874`, 
            1.`}, {-4.232050807568874`, 
            0.1339745962155625`}, {-3.232050807568874`, 
            1.866025403784441`}, {-3.732050807568874`, 
            1.`}, {-2.732050807568882`, 
            2.732050807568874`}, {-3.232050807568874`, 
            1.866025403784441`}, {-4.232050807568874`, 
            0.1339745962155625`}, {-4.732050807568874`, -0.732050807568875`}, {-4.732050807568874`, -0.732050807568875`}, {-4.732050807568874`, -1.732050807568874`}, {-4.732050807568874`, -1.732050807568874`}, {-4.232050807568874`, -2.598076211353316`}, {-4.232050807568874`, -2.598076211353316`}, {-3.732050807568874`, -3.464101615137751`}, {-3.732050807568874`, -3.464101615137751`}, {-2.866025403784441`, -3.964101615137749`}, {-2.866025403784441`, -3.964101615137749`}, {-2.`, -4.464101615137751`}, {-2.`, -4.464101615137751`}, {-1.133974596215558`, -4.964101615137751`}, {-1.133974596215558`, -4.964101615137751`}, {-0.133974596215559`, -4.964101615137751`}, {1.`, -3.732050807568874`}, {2.`, -3.732050807568874`}, {0.`, -3.732050807568874`}, {1.`, -3.732050807568874`}, {-1.`, -3.732050807568874`}, {0.`, -3.732050807568874`}, {2.`, -3.732050807568874`}, {2.999999999999996`, -3.732050807568874`}, {2.999999999999996`, -3.732050807568874`}, {3.866025403784433`, -3.232050807568874`}, {3.866025403784433`, -3.232050807568874`}, {4.366025403784433`, -2.366025403784437`}, {4.366025403784433`, -2.366025403784437`}, {4.866025403784437`, -1.5`}, {4.866025403784437`, -1.5`}, {4.866025403784433`, -0.5`}, {4.866025403784433`, -0.5`}, {4.866025403784441`, 0.5`}, {4.866025403784441`, 0.5`}, {4.866025403784437`, 
            1.5`}, {4.866025403784437`, 1.5`}, {4.366025403784441`, 
            2.366025403784441`}, {-4.232050807568878`, 
            2.598076211353312`}, {-4.732050807568878`, 
            1.732050807568874`}, {-4.732050807568878`, 
            1.732050807568874`}, {-5.232050807568878`, 
            0.8660254037844374`}, {-5.232050807568878`, 
            0.8660254037844374`}, {-5.732050807568878`, 
            0.`}, {-5.732050807568878`, 
            0.`}, {-6.232050807568878`, -0.8660254037844374`}, {-6.232050807568878`, -0.8660254037844374`}, {-6.232050807568878`, -1.866025403784437`}, {-6.232050807568878`, -1.866025403784437`}, {-5.732050807568878`, -2.732050807568874`}, {-5.732050807568878`, -2.732050807568874`}, {-5.232050807568878`, -3.598076211353314`}, {-5.232050807568878`, -3.598076211353314`}, {-4.732050807568878`, -4.464101615137753`}, {-0.133974596215559`, -4.964101615137751`}, {0.8660254037844339`, -4.964101615137753`}, {0.8660254037844339`, -4.964101615137753`}, {1.866025403784433`, -4.964101615137755`}, {1.866025403784433`, -4.964101615137755`}, {2.866025403784433`, -4.964101615137755`}, {2.866025403784433`, -4.964101615137755`}, {3.866025403784433`, -4.964101615137757`}, {3.866025403784433`, -4.964101615137757`}, {4.732050807568871`, -4.464101615137757`}, {4.732050807568871`, -4.464101615137757`}, {5.232050807568871`, -3.598076211353317`}, {5.232050807568871`, -3.598076211353317`}, {5.732050807568871`, -2.732050807568878`}, {5.732050807568871`, -2.732050807568878`}, {6.232050807568874`, -1.866025403784441`}, {4.366025403784441`, 
            2.366025403784441`}, {3.866025403784441`, 
            3.232050807568878`}, {3.866025403784441`, 
            3.232050807568878`}, {3.366025403784441`, 
            4.098076211353316`}, {3.366025403784441`, 
            4.098076211353316`}, {2.866025403784441`, 
            4.964101615137757`}, {2.866025403784441`, 
            4.964101615137757`}, {2.366025403784448`, 
            5.83012701892219`}, {2.366025403784448`, 
            5.83012701892219`}, {1.500000000000007`, 
            6.330127018922194`}, {1.500000000000007`, 
            6.330127018922194`}, {0.5000000000000071`, 
            6.330127018922194`}, {0.5000000000000071`, 
            6.330127018922194`}, {-0.4999999999999929`, 
            6.330127018922194`}, {-0.4999999999999929`, 
            6.330127018922194`}, {-1.499999999999992`, 
            6.330127018922194`}, {-0.3295510556225167`, 
            2.023808456385268`}, {-1.329551055622516`, 
            2.023808456385268`}, {-1.58789400781216`, -1.297303814205712`}, {-1.08789400781216`, -2.163329217990149`}, {1.917445063434673`, -0.7265046421795561`}, {2.417445063434676`, 
            0.139520761604885`}};

FuzzyUnion[points_, delta_:  0.01] := 
      Module[{rem}, 
        Map[Apply[Plus, First /@ #]/Length[#] &, 
          Flatten[First[
                  NestWhile[
                    Function[
                      r, {Append[r[[1]], #], rem} &[
                        rem = Rest[r[[2]]]; 
Flatten[
                          NestWhileList[
                            Function[x, 
                              rem = Complement[rem, 
                                  x]; 
Select[rem, 
                                Function[t, 
                                  Catch[If[# . # &[
                                        t[[1]] - #[[1]]] ≤ 
                                        delta^2, Throw[True]] & /@ 
                                      x; 
False]]]], {r[[2, 1]]}, # ≠ {} &], 1]]], {{}, MapIndexed[{##} &, #]}, 
                    Last[#] ≠ {} &]] & /@ 
              Fold[Function[{l, d}, 
                  Flatten[Split[
                          Sort[#, #1[[d]] < #2[[d]] &], #2[[d]] - #1[[d]] ≤ delta &] & /@ l, 1]], {points}, 
                Range[Length[points[[1]]]]], 1]]]

FuzzyUnion2[𝓅_?(MatrixQ[#, NumericQ] &), 𝒹_?
          NonNegative] := (Plus @@ #/Length[#]) & /@ 
        Flatten[Function[α, 
              Apply[# &, 
                Last /@ Rest[
                    NestWhileList[{#[[1]], 
                              Flatten[#[[2]]]} &[
                          NestWhile[
                            Function[σ, {#[[1]], {#[[2]], σ[[2]]}} &[{Complement[σ[[1]], #], #} &[
                                  Flatten[Fold[
                                        Function[{λ, μ}, {Complement[λ[[1]], #], {#, λ[[2]]}} &[
                                        Select[λ[[1]], (# . # &[#[[1]] - μ[[1]]] < 𝒹^2) &]]], {σ[[1]], {}}, σ[[2, 
                                        1]]][[2]]]]]], {Rest[#[[1]]], {{#[[1, 
                                    1]]}}}, (#[[2, 1]] =!= {}) &]] &, {MapIndexed[
                          C, α], {}}, #[[1]] =!= {} &]], {2}]] /@ 
            Fold[Function[{λ, δ}, 
                Flatten[Map[RotateRight[#, δ] &, 
                        Split[Sort[RotateLeft[#, δ] & /@ #], #2[[1]] - #1[[1]] < 𝒹 &], {2}] & /@ λ, 
                  1]], {𝓅}, 
              Range[Length[𝓅[[1]]]]], 1]

Large number of points and clusters, where partitioning the data is important to avoid (n^2) complexity:

bigtest = 
        Flatten[Table[{Cos[((n π)/8)], Sin[((n π)/8)]} + 
              0.02 {Random[], Random[]}, {50}, {n, 0, 15}], 1];

Show[Graphics[Point /@ bigtest], 
        AspectRatio -> Automatic];

Length[bigtest]

FuzzyUnion[bigtest, 0.03] // Timing

Here's a nasty example where each "cluster" lies on a spiral arm or short line segment, there are 6 clusters when delta is 1.1.

Show[Graphics[{PointSize[0.02], Point /@ spirals}], 
        AspectRatio -> Automatic];

Connectivity with delta = 1.1 or so:

Length[spirals]

FuzzyUnion[spirals, 1.1] // Timing

The Entries

A quick look at the entries.

A

FuzzyUnion[s_List, delta_] := 
      Map[Plus @@ #/Length[#] &, 
Module[{dist, incluster, 
            clusters, i, j, inserted}, 
dist[p1_, p2_] := 
            Sqrt[Apply[
                Plus, (p1 - 
                      p2)^2]]; 
clusters = {{s[[1]]}}; 
For[i = 2, 
            i ≤ Length[s], 
inserted = 
              False; 
For[
              j = 1, ! inserted  &&  
                j ≤ Length[clusters], 
If[
                Select[clusters[[j]], (dist[#, s[[i]]] < 
                          delta) &, 1] ≠ {}, 
                clusters[[j]] = 
                  Append[clusters[[j]], 
                    s[[i]]]; 
inserted = 
                  True
]; 
j++
]; 
If[! inserted, 
              clusters = 
                Append[clusters, {s[[i]]}]]; 
i++
]; 
clusters
]
]

B

FuzzyUnion[pointSet_, delta_] := 
        Module[
{distSqr, avrg, outsider = pointSet, 
            center, numPoints, insider, p, 
            cluster = {}}, 
distSqr[x_, y_] := 
            Plus @@ ((x - y)^2); 
avrg[x_] := 
            Plus @@ x/Length[x]; 
While[
            outsider =!= {}, 
            center = First@
                outsider; 
            numPoints = 
              1; 
            insider = {}; 
            While[(p = 
                    Select[outsider, 
                      Chop[distSqr[(center*numPoints + #)/(numPoints + 
                                      1), #] - delta^2] ≤ 
                          0 &]) =!= {}, 
                        outsider = 
                Complement[outsider, 
                  p]; 
                        insider = 
                Join[insider, 
                  p ]; 
                        numPoints = 
                Length@insider; 
                        center = 
                avrg@insider]; 
            AppendTo[cluster, center]]; 
Return[cluster]];

C

FuzzyUnion[a:{{_?NumericQ, _?NumericQ}..}, (tol_)?NumericQ] := 
  Module[{ma, tag, untag, collectIt, tst, maxLength, atx, aty}, 
  	ma = Table[tag[i][a[[i]]], {i, 1, Length[a]}]; 
    Scan[(untag[Head[#1][[1]]] = #1[[1]]) & , ma]; 
    collectIt = Table[{i}, {i, 1, Length[ma]}]; 
    tst[tag[tx_][x_], tag[ty_][y_]] := 
    	If[Sqrt[Plus @@ (x - y)^2] <= tol, 
      	   ( atx = collectIt[[tx]];
      	     aty = collectIt[[ty]];
      	     collectIt[[tx]] = {collectIt[[tx]], aty}; 
      	     collectIt[[ty]] = {collectIt[[ty]], atx}; 
       		 True ), 
       		 False ]; 
    ma = Union[ma, SameTest -> tst];
    collectIt = Union[Union /@ ( Flatten /@ collectIt )];
    maxLength = Max[ Length /@ collectIt ];
    collectIt = Select[ collectIt, ( Length[ # ] == maxLength )& ];
    (Plus @@ untag /@ #1/Length[#1] & ) /@ collectIt ]

D

Norm[vec_]:= Sqrt[Plus @@ (vec^2)];

FuzzyUnion[pts_,delta_]:= 
	Module[{mat,cls}, 
		mat = Map[If[Norm[Subtract @@ #] < delta,1,0]&,Outer[List,pts,pts,1],{2}];
		cls = FixedPoint[Map[If[# == 0,0,1]&,mat.#,{2}]&,mat];
		cls = Extract[cls,Union[First /@ (Position[cls,#]& /@ cls)]];
		Inner[Times,#,pts]/(Plus @@ #)& /@ cls
	];

E

\(\(\(Norm[vec_] := Sqrt[Plus @@ \((vec^2)\)];\)\(
\)
    \)\)
FuzzyUnion[pts_, delta_] := 
        Module[{mat, cls}, 
          mat = Map[If[Norm[Subtract @@ #] < delta, 1, 0] &, 
              Outer[List, pts, pts, 1], {2}]; 
cls = 
            FixedPoint[Map[If[# == 0, 0, 1] &, mat . #, {2}] &, mat] // 
              Union; 
Inner[Times, #, 
                  pts]/(Plus @@ #) & /@ cls];

F

Norm[vec_]:=Sqrt[Plus@@(vec^2)];

CloseQ[pt_,lst_,delta_]:= Or @@((Norm[pt-#] < delta)& /@ lst);

GetClass[{cl_,pts_},delta_]:=
	Module[{new,rest = pts,cls = {}},
		If[pts === {},
			{cl,pts},
			new = {First[pts]};
			While[new =!= {},
				cls = Union[cls,new];
				rest = Complement[rest,new];
				new = Select[rest,CloseQ[#,new,delta]&]
			];
			{Append[cl,cls],rest}
		]
	];
	
FuzzyUnion[pts_,delta_]:=
	Module[{cl = {},rest = pts},
		While[rest =!= {},{cl,rest} = GetClass[{cl,rest},delta]];
		Map[(Plus @@ #)/Length[#]&,cl]
	];

G

Needs["DiscreteMath`Combinatorica`"]

    
\(\(\(nearenough = 
        Compile[{{x, _Real, 2}, {δ, _Real}}, 
          With[{o = 
                Outer[Plus, x, \(-x\), 1, 
                  1], δsquared = δ*δ}, 
            Map[If[Dot[#, #] <= δsquared, 1, 0] &, o, {2}]]];\)\(
\)
    \)\)
FuzzyUnion[x_, δ_] := 
      Map[With[{p = Part[x, #]}, Total[p]/Length[p]] &, 
        ConnectedComponents[
          FromAdjacencyMatrix[nearenough[x, δ]]]]

H

\(\(\(dist[a_, b_] := \@With[{d = a - b}, d . d]\)\(
\)
    \)\)
<< DiscreteMath`Combinatorica`

    
\(FuzzyUnion[
        d : {{__?NumberQ} .. }, Δ_?
          NumberQ] := \(Plus @@ #\/Length[#] &\) /@ \(\((d[[#]] &)\) /@ 
          ConnectedComponents[
            MakeGraph[d, dist[#1, #2] < Δ &, 
              Type -> Undirected]]\)\)

I

dist[a_, b_] := (Sqrt[With])[{d = a - b}, d . d]

    
\(FuzzyUnion[
        data : {{__?NumberQ} .. }, Δ_?
          NumberQ] := \(Plus @@ #\/Length[#] &\) /@ \(\((data[[#]] &)\) /@ \((\((Join @@@ \(\((Position[#, d_ /; d < Δ, 2] &)\) /@ 
                    Outer[dist, data, data, 1]\))\) //. {a___, 
                  b : {___, x_, ___}, c___, d : {___, x_, ___}, 
                  e___} :> {a, Union[b, d], c, 
                  e})\)\)\)

J

dist[a_, b_] := (Sqrt[With])[{d = a - b}, d . d]

    
extract[{cc_, r_}] := 
      Module[{n = 
            Select[r, MemberQ[#1, Alternatives @@ Join @@ cc] &]}, {Join[
            cc, n], DeleteCases[r, 
            Alternatives @@ n]}]

    
connect[l_] := 
      Module[{cc, r}, 
        Union @@@ First[
            NestWhile[({cc, r} = 
                    FixedPoint[
                      extract, {{First[#[[2]]]}, 
                        Rest[#[[2]]]}]; {Append[#[[1]], cc], r}) &,  {{}, 
                l},  Last[#] =!= {} &]]]

    
\(FuzzyUnion[
        data : {{__?NumberQ} .. }, Δ_?
          NumberQ] := \(Plus @@ #\/Length[#] &\) /@ \(\((data[[#]] &)\) /@ 
          connect[Join @@@ \(\((Position[#, d_ /; d < Δ, 
                      2] &)\) /@ Outer[dist, data, data, 1]\)]\)\)

K

FuzzyUnion[x_List /; Length[Union[Map[Length, x]]] == 1, 
            tol_ /; tol > 0] :=  
          Map[If[Length[#] > 1, Plus @@ #/Length[#], #[[1]]] &, 
            Split[x, Norm[#1 - #2] < tol &]];

L

\(FuzzyUnion[p_, d_] := 
        Module[{t = {p}}, 
\ \ \ \ Do[
            t = Flatten[\(Split[
                      Sort[#, 
                        OrderedQ[{#1[\([k]\)], #2[\([k]\)]}] &], \((#2[\([k]\)] - #1[\([k]\)])\) < d &] &\) /@ t, 1], {k, 
              Length[p[\([1]\)]]}]; 
\ \ \ \ \(\((Plus @@ #/
                  Length[#])\) &\) /@ t
\ \ \ \ ]\)

M

distance[p1_, p2_] := Sqrt[# . #] &[p1 - p2] // N

 mean[points_] := Plus @@ points/Length[points] // N

 test[{l1_, l2_}, delta_]:=Scan[If[distance @@ # > delta, Return[False]] &, 
                Flatten[Outer[List, l1, l2, 1], 1]]/.Null->True

 FuzzyUnion[points_, delta_]:=List /@ points//.{a___, l1 : {{__} .. }, b___, l2 : {{__} .. }, 
                      c___} /; test[{l1, l2}, delta]:>{a, b, c, Join[l1, l2]}/.l_:>mean /@ l

N

\(FuzzyUnion[data_?\((MatrixQ[#, \ NumericQ]\  &)\), \ 
        eps_?NumericQ]\  := \ 
\ \ \(\((Plus\  @@ \ #/
              Length[#])\)\  &\)\  /@ \ \((Partition[data, \ 
              1]\  //. \ 
\ \ \ \ {a___List, \ b_List, \ c___List, \ 
                  d_List, \ 
                  e___List}\  /; \ 
\ \ \ \ \ \ \((\((Length[b]\  - \ 
                            1)\) \((Length[d]\  - \ 1)\)\  == \ 
                      0\  && \ 
\ \ \ \ \ \ \ \ Min[
                        Outer[\(# . #\  &\)@\((#1\  - \ #2)\)\  &, \ b, \ 
                          d, \ 1]]\  < \ 
                      eps^2)\)\  :> \ 
\ \ \ \ \ \ \ \ \ \ {Join[b, \ d], \ 
                a, \ c, \ e})\)\)

O

\(\(\(getAllClusters[iList_List, 
          iDelta_?NumberQ] := 
Module[{firstCluster, 
            remainingClusters}, 
If[
            iList ≠ {}, 
firstCluster = 
              getCluster[Drop[iList, 1], 
                iList[[1]], 
                iDelta]; 
remainingClusters = 
              getAllClusters[Complement[iList, firstCluster], 
                iDelta]; 
If[
              Flatten@remainingClusters == {}, 
{firstCluster}
, 
Join[{firstCluster}, 
                remainingClusters]
]
, 
{}
]
];\)\(
\)
    \)\)
\(\(\(dist[a_, b_] := Sqrt[\((a - b)\) . \((a - b)\)]\)\(
\)
    \)\)
\(\(\(getCluster[iList_List, x_List, iDelta_?NumberQ] := 
        Module[{firstCluster, 
            remainingClusters}, 
firstCluster = 
            Cases[iList, 
              point_ /; dist[point, x] < 
                  iDelta]; 
remainingClusters = \(getCluster[Complement[iList, firstCluster], #, iDelta] &\) /@ 
              firstCluster; 
Union[{x}, firstCluster, 
            Flatten[remainingClusters, 1]]
];\)\(
\)
    \)\)
FuzzyUnion[iList_List, 
        iDelta_?NumberQ] := (Plus @@ #/Length[#]) & /@ 
        getAllClusters[iList, iDelta]

P

MPCCentre[l_List] := Plus @@ l/Length@l;
SqrDist[l_List] := #^2 & /@ l;
Distance[pt1_, pt2_] := Sqrt[Plus @@ SqrDist[pt1 - pt2]];
OrderPointsQ[pt1_, pt2_] := 
        With[{sd1 = SqrDist@pt1, 
            sd2 = SqrDist@pt2}, (diff . sd1 < 
                diff . sd2) ∧ (Plus @@ sd1 < 
                Plus @@ sd2) ];

    
FuzzyUnion[l_List, δ_] := 
        Block[{diff = Range@Length@First@l}, 
          MPCCentre /@ 
            Split[Sort[l, 
                OrderPointsQ], (Distance[#1, #2] < δ) &]];

Q

FuzzyUnion[pts_List, delta_Real] := 
      Module[{dist, pairs, neighbors, centers}, 
dist = 
          Table[Max[
              Abs[pts[[n]] - 
                  pts[[m]]]], {n, 1, 
              Length[pts] - 1}, {m, n + 1, 
              Length[pts]}]; 
pairs = 
          Position[dist, 
              x_?(# < delta &), {0, ∞}] /. {x_, y_} -> {x, 
                x + y}; 
neighbors = 
          FixedPoint[(Cases[
                  Table[Cases[#, {___, n, ___}] // Flatten // Union, {n, 
                        1, 60}] // Union, {__}]) &, pairs]; 
        centers = 
          Table[Plus  @@  pts[[neighbors[[n]]]]/Length[neighbors[[n]]], {n, 1, 
              Length[neighbors]}]

]

And the winners are

Richard Mercer: Clean functional program:

FuzzyUnion[pts_, delta_] := 
        Module[{mat, cls}, 
          mat = Map[If[Norm[Subtract @@ #] < delta, 1, 0] &, 
              Outer[List, pts, pts, 1], {2}]; 
cls = 
            FixedPoint[Map[If[# == 0, 0, 1] &, mat . #, {2}] &, mat] // 
              Union; 
Inner[Times, #, 
                  pts]/(Plus @@ #) & /@ cls];

Bob Nachbar: Best presentation, with all three (four) submissions correct, including this one with lots of pattern matching:

dist[a_, b_] := (Sqrt[With])[{d = a - b}, d . d]

    
\(FuzzyUnion[
        data : {{__?NumberQ} .. }, Δ_?
          NumberQ] := \(Plus @@ #\/Length[#] &\) /@ \(\((data[[#]] &)\) /@ \((\((Join @@@ \(\((Position[#, d_ /; d < Δ, 2] &)\) /@ 
                    Outer[dist, data, data, 1]\))\) //. {a___, 
                  b : {___, x_, ___}, c___, d : {___, x_, ___}, 
                  e___} :> {a, Union[b, d], c, 
                  e})\)\)\)

Seth Chandler: Combined Combinatorica with a compiled function for computing the adjacency matrix:

Needs["DiscreteMath`Combinatorica`"]

    
\(\(\(nearenough = 
        Compile[{{x, _Real, 2}, {δ, _Real}}, 
          With[{o = 
                Outer[Plus, x, \(-x\), 1, 
                  1], δsquared = δ*δ}, 
            Map[If[Dot[#, #] <= δsquared, 1, 0] &, o, {2}]]];\)\(
\)
    \)\)
FuzzyUnion[x_, δ_] := 
      Map[With[{p = Part[x, #]}, Total[p]/Length[p]] &, 
        ConnectedComponents[
          FromAdjacencyMatrix[nearenough[x, δ]]]]

Bruce Torrence: Redefined the problem to use the taxi-cab metric (or actually, the maximal metric) for an elegant and very efficient (incorrect) solution:

\(FuzzyUnion[p_, d_] := 
        Module[{t = {p}}, 
\ \ \ \ Do[
            t = Flatten[\(Split[
                      Sort[#, 
                        OrderedQ[{#1[\([k]\)], #2[\([k]\)]}] &], \((#2[\([k]\)] - #1[\([k]\)])\) < d &] &\) /@ t, 1], {k, 
              Length[p[\([1]\)]]}]; 
\ \ \ \ \(\((Plus @@ #/
                  Length[#])\) &\) /@ t
\ \ \ \ ]\)

Some WRI solutions

All of the submitted entries (except for Bruce Torrence's) have (n^(2 ))complexity, making them exceedingly slow on the bigtest example (the fastest, Seth Chandler's code ran in 10 seconds). 

Here are a couple of WRI solutions, using functional programming and a pre-partitioning of the points for very fast solutions:

By Oyvind, with inspirations from an early suggestion by Michael Trott:

FuzzyUnion[points_, delta_:  0.01] := 
      Module[{rem}, 
        Map[Apply[Plus, First /@ #]/Length[#] &, 
          Flatten[First[
                  NestWhile[
                    Function[
                      r, {Append[r[[1]], #], rem} &[
                        rem = Rest[r[[2]]]; 
Flatten[
                          NestWhileList[
                            Function[x, 
                              rem = Complement[rem, 
                                  x]; 
Select[rem, 
                                Function[t, 
                                  Catch[If[# . # &[
                                        t[[1]] - #[[1]]] ≤ 
                                        delta^2, Throw[True]] & /@ 
                                      x; 
False]]]], {r[[2, 1]]}, # ≠ {} &], 1]]], {{}, MapIndexed[{##} &, #]}, 
                    Last[#] ≠ {} &]] & /@ 
              Fold[Function[{l, d}, 
                  Flatten[Split[
                          Sort[#, #1[[d]] < #2[[d]] &], #2[[d]] - #1[[d]] ≤ delta &] & /@ l, 1]], {points}, 
                Range[Length[points[[1]]]]], 1]]]

FuzzyUnion[bigtest, 0.03] // Timing

Michael's suggestion:

Clear[FuzzyUnion];

FuzzyUnion[𝓅_?(MatrixQ[#, NumericQ]&), 𝒹_?NonNegative] := 
((* calculate center *) Plus @@ #/Length[#])& /@
Flatten[Function[α, Apply[#&, Last /@ Rest[
(* separate all clusters *)
NestWhileList[{#[[1]], Flatten[#[[2]]]}&[
(* recursively find points of a cluster; find "chains" *)
NestWhile[Function[σ, {#[[1]], {#[[2]], σ[[2]]}}&[{Complement[σ[[1]], #], 
 #}&[(* find and remove points in distance 𝒹 *)
     Flatten[Fold[Function[{λ, μ}, 
      {Complement[λ[[1]], #], (* form nested lists, not flat ones *)
      {#, λ[[2]]}}&[Select[λ[[1]], (#.#&[#[[1]] - μ[[1]]] < 𝒹^2)&]]], 
         {σ[[1]], {}}, σ[[2, 1]]][[2]]]]]], {Rest[#[[1]]], {{#[[1, 1]]}}}, 
    (#[[2, 1]] =!= {})&]]&, (* index all points to keep multiples *)
    {MapIndexed[C, α], {}}, #[[1]] =!= {}&]], {2}]] /@
        (* separate cluster if possible by coordinate values;
           avoid n^2 complexity in the number of points *)
        Fold[Function[{λ, δ}, Flatten[Map[RotateRight[#, δ]&, 
        Split[Sort[RotateLeft[#, δ]& /@ #], #2[[1]] - #1[[1]] < 𝒹&], 
         {2}]& /@ λ, 1]], {𝓅}, Range[Length[𝓅[[1]]]]], 1]

FuzzyUnion[bigtest, 0.03] // Timing