Here is a method that is a bit like using Nearest on images (in that the internal code for that has some similarities). I crib from code located here. The idea quite abbreviated, is to take a sub-array of low frequency Fourier components (I use a DCT for this), flatten these arrays into vectors, extract a singular value decomposition keeping some number of singular values, and use the result to (1) preprocess and (2) look up the test images. We find several "nearest" ones and assign a score by weighting by inverse of proximity to lookup vector.
nearestImages[ilist_, vals_, dn_, dnum_, keep_] :=
Module[
{images = ilist, dcts, top,
topvecs, uu, ww, vv, udotw, norms},
dcts = Map[FourierDCT[# - Mean[Flatten[#]], dnum] &, images];
top = dcts[[All, 1 ;; dn, 1 ;; dn]];
topvecs = Map[Flatten, top];
topvecs = Map[# &, topvecs];
{uu, ww, vv} =
SingularValueDecomposition[topvecs, keep];
udotw = uu.ww;
norms = Map[Sqrt[#.#] &, udotw];
udotw = udotw/norms;
{Nearest[udotw -> Transpose[{udotw, vals}]], vv}]
processInput[ilist_, vv_, dn_, dnum_] :=
Module[
{images = ilist, dcts, top,
topvecs, tdotv, norms},
dcts = Map[FourierDCT[# - Mean[Flatten[#]], dnum] &, images];
top = dcts[[All, 1 ;; dn, 1 ;; dn]];
topvecs = Map[Flatten, top];
topvecs = Map[# &, topvecs];
tdotv = topvecs.vv;
norms = Map[Sqrt[#.#] &, tdotv];
tdotv = tdotv/norms;
tdotv]
guesses[nf_,tvecs_,n_]:=Module[
{nbrs,probs,probsB,bestvals},
probs=Table[
Module[{res=nf[tvecs[[j]],n],dists},
dists=1/Map[Norm[tvecs[[j]]-#,3/2]&,res[[All,1]]];
Thread[{res[[All,2]],dists/Total[dists]}]],
{j,Length[tvecs]}];
probsB=Map[Normal[GroupBy[#,First]]&,probs]/.(val_->vlist:{{val_,_}..}):>(val->Total[vlist[[All,2]]]);
probs=(Range[0,9]/.probsB)/.Thread[Range[0,9]->0];
bestvals=Map[First[Ordering[#,1,Greater]]&,probs,{1}]-1;
bestvals
]
correct[guess_,actual_]/;
Length[guess]==Length[actual]:=
Count[guess-actual,0]
correct[__]:=$Failed
The example proceeds from the point of having imported the arrays into characterImages, as in the original post. We separate inot training and test image arrays and label sets.
trainImages = characterImages[[3, All]]/256.;
trainLabels = Flatten[characterImages[[4, All]]];
testImages = characterImages[[1, All]]/256.;
testLabels = Flatten[characterImages[[2, All]]];
The method has some tuning parameters. The ones used below are in the general vicinity of what is used in the tests at the link given above. We use four neighbors although some experiments indicate 3 might be a better choice for this particular data set. Total run time is a few seconds.
keep = 40;
dn = 20;
dst = 4;
AbsoluteTiming[{nf, vv} =
nearestImages[trainImages,
trainLabels, dn, dst, keep];]
AbsoluteTiming[testvecs =
processInput[testImages, vv, dn, dst];]
guessed = guesses[nf, testvecs, 4];
AbsoluteTiming[corr = correct[guessed, testLabels]]
N[corr/tlen]
(* Out[452]= {2.221543, Null}
Out[453]= {0.114258, Null}
Out[454]= {1.296956, Null}
Out[456]= 0.942231075697 *)
So 94.2% correct, which is not bad. If we bring the number of retained singular values way up we can hit 95% correct.
