7
$\begingroup$

I wanted to create the flag you create when you average over all the flags of the world, for this little post: medium

av = Total[{##}]/Length[{##}] &;
cd = CountryData;

ImageApply[av, #] &@
  (ImageResize[#, {120, 85}] &/@     
    (ColorReplace[#, White] &/@(cd[#, "Flag"] & /@ 
      cd[])))    

However I was surprised when I got the Union Jack in the upper left corner. Looking at the list of flags, I saw that the flags with the Union Jack are really over-represented. By using CountryData["Groups"] I couldn't find a group that filters them all out.

Anyone has an idea how I can remove from the list of flags

cd[#, "Flag"] & /@ cd[]

all the flags that have the Union Jack pattern, except one? Is there something like image recognition?

average flag

$\endgroup$
5
  • 5
    $\begingroup$ The technical term is "imperialism", not "over-representation". $\endgroup$ Nov 16 '15 at 21:04
  • 1
    $\begingroup$ Have you considered perhaps weighing each country's flag by that country's population when averaging them? $\endgroup$
    – MarcoB
    Nov 16 '15 at 22:22
  • 1
    $\begingroup$ This could be useful for you: Flags of all countries grouped by similarity $\endgroup$ Nov 17 '15 at 8:32
  • 2
    $\begingroup$ (1) @VitaliyKaurov That's an interesting post but the code is far slower than need be. Why compute Nearest from scratch for every flag, when one can precompute a NearestFunction? (Which is what NearestFunction is intended for handling.) Compare... $\endgroup$ Nov 17 '15 at 22:53
  • 3
    $\begingroup$ (2) In[524]:= countries = CountryData["Countries", "Name"]; flags = Rasterize /@ CountryData["Countries", "Flag"]; AbsoluteTiming[ similarities = # -> First[Nearest[DeleteCases[flags, #], #]] & /@ flags;] AbsoluteTiming[nf = Nearest[DeleteDuplicates[flags]];] AbsoluteTiming[similarities2 = Map[# -> nf[#, 2][[2]] &, flags];] similarities === similarities2 Out[526]= {131.66955, Null} Out[527]= {0.609352, Null} Out[528]= {0.86178, Null} Out[529]= True $\endgroup$ Nov 17 '15 at 22:53
9
$\begingroup$

Not very pretty, in fact quite bland, but here is a method that gives relatively smaller weights to flags that tend to have fairly close (in some measure) neighbors.

First we bring in the flags and give them common sizes.

flags =
  ConformImages[Map[CountryData[#, "Flag"] &,
    CountryData[]]];
flagdata = Map[ImageData, flags];

We will first illustrate that, with no reweighting, the method recovers the known unweighted average.

weights = ConstantArray[1, Length[flags]];
newflagdata = MapThread[Times, {flagdata, weights}];
Image[Total[newflagdata]/Total[weights]]

enter image description here

Now we introduce some machinery useful for locating "nearby" images. I won't go into the details of how (or how well) it works. Suffice it to say that it has its nicer points.

keep = 28;
dn = 11;
dst = 4;
Clear[nearestImages, processInput];

nearestImages[ilist_, vals_, dn_, dnum_, keep_] :=
 Module[
  {idata, images = ilist, dcts, top,
   topvecs, uu, ww, vv, udotv, norms},
  idata = Map[ImageData, images];
  dcts = Map[FourierDST[#, dnum] &, idata];
  top = dcts[[All, 1 ;; dn, 1 ;; dn]];
  topvecs = Map[Flatten, top];
  topvecs = Map[# - Mean[#] &, topvecs];
  {uu, ww, vv} =
   SingularValueDecomposition[topvecs, keep];
  udotv = uu.ww;
  norms = Map[Sqrt[#.#] &, udotv];
  udotv = udotv/norms;
  udotv = Join[udotv, Transpose[{Log[norms]}], 2];
  {Nearest[udotv -> vals], vv}]

processInput[ilist_, vv_, dn_, dnum_] :=
 Module[
  {idata, images = ilist, dcts, top,
   topvecs, tdotv, norms},
  idata = Map[ImageData, images];
  dcts = Map[FourierDST[#, dnum] &, idata];
  top = dcts[[All, 1 ;; dn, 1 ;; dn]];
  topvecs = Map[Flatten, top];
  topvecs = Map[# - Mean[#] &, topvecs];
  tdotv = topvecs.vv;
  norms = Map[Sqrt[#.#] &, tdotv];
  tdotv = tdotv/norms;
  tdotv = Join[tdotv, Transpose[{Log[norms]}], 2];
  tdotv]

With this machinery in place we preprocess flags to create smallish vectors useful for lookup purposes. Also good for defining the closeness measure below.

Timing[{nf2, vv2} =
  nearestImages[flags, Range[Length[flags]], dn, dst, keep];
 testvecs = processInput[flags, vv2, dn, dst];]

(* Out[54]= {0.835387, Null} *)

I define a crude measure of flag image closeness wherein smaller means closer. For each flag we will sum proximities to the four nearest neighboring flags, or rather we do this between the preprocessed vectors created from the flags.

proximity[f1_, f2_] :=
 Abs[Total[(f1 - f2)^2/(1 + f1^2 + f2^2)]]

weight[flagnum_] := 
 Sum[proximity[testvecs[[flagnum]], testvecj], {testvecj, 
   Map[testvecs[[#]] &, nf2[testvecs[[flagnum]], 5][[2 ;; -1]]]}]

Now compute the weights and use them, as in the equally weighted case above, to form weighted flag data which we then average.

weights = Table[weight[j], {j, Length[flags]}];
newflagdata = MapThread[Times, {flagdata, weights}];
Image[Total[newflagdata]/Total[weights]]

enter image description here

Prediction: No major wars will be fought over this flag. It's too boring.

$\endgroup$
8
  • 2
    $\begingroup$ +1, but you may find that wars don't need a good reason $\endgroup$ Nov 16 '15 at 23:07
  • $\begingroup$ [With apologies to Toledans...] @Belisarius Oh I don't know. I could easily see Ohio going to war against Michigan, to make them take back Toledo. $\endgroup$ Nov 16 '15 at 23:29
  • 1
    $\begingroup$ @Belisarius It was probably all a subterfuge from the University of Illinois to weaken both of them. Has not helped us in the least, I'm afraid. (Reminds me of when my wife and I went into a Columbus bar, on a day their football team was underranked and playing the then-undefeated Illini in Champaign. They were very nice to us...) $\endgroup$ Nov 16 '15 at 23:55
  • 1
    $\begingroup$ @belisarius In a way that's how we felt, in terms of being recognized as Champaign residents. Not so much a matter of hostility, as scorn for our heavily undeserved high college football ranking. Which OSU was actively obliterating that afternoon, on the screen in front of us. $\endgroup$ Nov 17 '15 at 0:10
  • 1
    $\begingroup$ @J.M. Well, according to dates and times, I was in fact the last guy to answer this particular question (I think that means I met your expectation). $\endgroup$ Nov 17 '15 at 15:27
6
$\begingroup$

Not exactly an image processing answer, but seems to work:

uks = First /@ Select[{#, CountryData[#, "FlagDescription"]} & /@ 
               CountryData[], ! StringFreeQ[#[[2]], "UK"] &]

{"Anguilla", "Australia", "Bermuda", "BritishVirginIslands", \
"CaymanIslands", "CookIslands", "FalklandIslands", "Fiji", \
"Montserrat", "NewZealand", "Niue", "PitcairnIslands", "SaintHelena", \
"TurksCaicosIslands", "Tuvalu"}

Processing it with your program (unchecked but slightly modified for v9)

av = Total[{##}]/Length[{##}] &;
cd = CountryData;

ImageApply[
   av, #] &@(ImageResize[#, {120, 
      85}] & /@ (ColorReplace[
       If[ImageQ@#, #, Rasterize@#, Rasterize@#], 
       White] & /@ (cd[#, "Flag"] & /@ Complement[cd[], uks])))

Mathematica graphics

$\endgroup$
3
  • $\begingroup$ av can't be replaced by Mean[]? $\endgroup$
    – J. M.'s torpor
    Nov 17 '15 at 1:54
  • 1
    $\begingroup$ @J.M. I haven't really looked into the OP calcs. Just worried about classifying imperial and non-imperial flags $\endgroup$ Nov 17 '15 at 3:44
  • 1
    $\begingroup$ Next question: What about the very obvious 3x3 stripes? (And the somewhat less obvious diagonals? Should they be removed? Should they be measured? I propose the latter, and in particular that we argue over whether to describe in terms of yards or meters (or, gasp, metres). $\endgroup$ Nov 17 '15 at 15:30

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.