Improving identicon graphics

Question

This question has two parts, a technical part about graphics, and a creative part. I'll accept answers primarily re the first part.

The application is to come up with graphical identicons to distinguish data layers. The approach is to leverage the file system and simply tokenize the paths.

This function takes file paths (as generated by say FileNames) as input, tokenize them, and use the prefix of a hash code (eg MD5 here) to color the path components.

Using the handy position-coded curry "bullet" operator:

\[Bullet] /: f_[pre___, \[Bullet] , post___] := 
  With[{n = Length[List@pre], m = Length[List@post]} ,
    Curry[f, Join[Range[n], {n + m + 1}, Range[m] + n]][pre, post] ];

The identicon generator becomes:

pathFlagIdenticon[h_] :=      
  Query[StringSplit[\[Bullet], "/"]] /* 
   Query[All, 
    Hash[\[Bullet], "MD5"] /* IntegerDigits[\[Bullet], 8, 36] /* 
     Query[1 ;; 3 h] /* 
     BlockMap[
      Query[{Total /* OddQ , (#/7 &) /* Apply[RGBColor]} /* 
        Replace[{{True, rgb_} :> rgb, {False, rgb_} :> 
           White}]], \[Bullet], 3]] /* Image /* 
   ImageRotate[\[Bullet], Pi/2] /* 
   Show[\[Bullet], ImageSize -> {60, 30}, PlotRange -> {{0, 10}, All},
     AspectRatio -> 1/3]; 

The graphics generated by each path component is a vertical column (currently only using a fraction of the hash string) and multiple path components are arranged horizontally - hence "pathFlag", so all files with the same path prefix share the same vertical stripes starting at left.

This works ok eg, given files:

{".DS_Store", 
"Readme.gdoc", 
"SUBMISSION/Data/Dictionaries/.DS_Store", "SUBMISSION/Data/Dictionaries/heloc_data_dictionary-2-Original.xlsx",
"SUBMISSION/Data/Dictionaries/heloc_data_dictionary-2.tsv",
"SUBMISSION/Data/Dictionaries/helocDataDictionary-Original.gsheet",
"SUBMISSION/Data/Dictionaries/helocDataDictionary.tsv",
"SUBMISSION/Data/Dictionaries/MaxDelq.gsheet",
"SUBMISSION/Data/.DS_Store"\
...}

Gives:

Dataset[files ][All, 
   StringDrop[\[Bullet], StringLength[path]] /* {pathFlagIdenticon[4],
      Identity}] // Normal // Column

(figure shows just a portion)

However, attempting to improve the graphics to include not just colored squares but also other shapes, eg circles,

graphicsRules = With[{z = 1, au = Automatic},
   {
    {{n_ /; Mod[n, 3] == 0, rgb_}, pos_} :> 
     Inset[Graphics@{rgb, Disk[]}, pos, {0, 0}, z],
    {{n_ /; Mod[n, 3] == 1, rgb_}, pos_} :> 
     Inset[Graphics@{rgb, Rectangle[]}, pos, {0, 0}, z],
    {{n_ /; Mod[n, 3] == 2, rgb_}, pos_} :> 
     Inset[Graphics@{White, Rectangle[]}, pos, {0, 0}, z]
    }
   ];

Run into problems with Inset. So first, what are the appropriate Inset options to render each cell contained in a unit square?

pathFlagWithShapes[h_] :=
  Query[StringSplit[\[Bullet], "/"]] /* 
   Query[All, 
    Hash[\[Bullet], "MD5"] /* IntegerDigits[\[Bullet], 8, 36] /* 
     Query[1 ;; 3 h] /* 
     BlockMap[Query[{Total , (#/7 &) /* Apply[RGBColor]} ], \[Bullet],
       3]] /* MapIndexed[
    List /* Replace[graphicsRules], \[Bullet], {2}] /* Graphics /*  
   ImageRotate[\[Bullet], 0*Pi/2] /* 
   Show[\[Bullet], ImageSize -> 7 {30, 30}, PlotRange -> {All, All}, 
    AspectRatio -> 1/1, Frame -> True];

The output is not as intended:

Dataset[files ][All, 
   StringDrop[\[Bullet], 
     StringLength[path]] /* {pathFlagWithShapes[4], Identity}] // 
  Normal // Column

Why are the graphics ranges going to ~200 when each is being indexMapped to no more than ~10 path components and each graphics element is supposed to be unit size?

That's the technical graphics question.

In addition to circles, would like to add triangle of various orientations, Harvey balls (disks that span not 2Pi angle but some multiple of Pi/2).

The creative part is, perhaps there are other graphical elements that would make the various paths even more distinguishable?

Answer 1

In what follows I'll present a possible solution to the problem in the question. I will not report on alternative graphical elements, but I will present an implementation that can have the following effect on a list of paths (these are simulated data, not the ones provided in the question-the discussion below uses original data from the question)

• "Why it doesn't work as expected?"

I'm not sure what's expected, but I can understand how the output seems out of whack. I think the most probable culprit is the definition of graphicsRule; in particular, the undesirable visual result is probably related to the parameters supplied to Inset therein.

Let's look at an example:

I will define a stripped down form of pathFlagWithShapes where everything after Graphics (ie ImageRotate etc) is removed (I won't include the code here to avoid clutter). Evaluating this reduced form of pathFlagWithShapes on the supplied files returns something like the following excerpts (again, won't include all the output for obvious reasons):

(these are the second and third entries of the output, presented side-by-side)

The first impression is that the Disk's are somehow off center; also, there seems to be an awful lot of white space. To investigate, we'll redefine graphicsRule (this time, using SetDelayed because otherwise the Graphics primitives complain-its suppressed by the semicolon used in the original code) so as to make all White Rectangle's, Orange to enhance visibility. (A portion of) the results are presented below:

Seeing all this orange color suggests that the relative positions of the circles and the rectangles are incompatible. To remedy that, we'll edit the previous definition of graphicsRules, namely we'll replace Inset[Graphics@{rgb, Disk[]}, pos, {0, 0}, z] with Inset[Graphics@{rgb, Disk[]}, pos, {-1, -1}, z]. Evaluating once more returns:

(again, these are the second and third entries of the output from evaluation when using the restricted form of pathFlagWithShapes)

Finally, we'll augment the definition of Graphics in pathFlagWithShapes (see above) with

Graphics[\[Bullet], PlotRange -> {{1, Automatic}, {1, 5}}, ImageSize -> Tiny]

and obtain

The code used so far reads

(*  wasn't sure what to use for path *)
With[{path = "C:\\", h = 4}, 
  Dataset[files][All, StringDrop[\[Bullet], StringLength[path]] /*
    {pathFlagWithShapes[h], Identity}] // Normal // Column
 ]

(* short version with augmented Graphics *)
pathFlagWithShapes[h_] := Query[StringSplit[\[Bullet], "/"]] /* 
  Query[All, Hash[\[Bullet], "MD5"] /* IntegerDigits[\[Bullet], 8, 36] /* 
    Query[1 ;; 3 h] /* 
      BlockMap[Query[{Total, (#/7 &) /* Apply[RGBColor]}], \[Bullet], 3]] /*     
        MapIndexed[List /* Replace[graphicsRules], \[Bullet], {2}] /*
          Graphics[\[Bullet], PlotRange -> {{1, Automatic}, {1, 5}}, ImageSize -> Tiny
 ]

(* changed Set to SetDelayed, colors and third argument of Inset for Circle's *)
graphicsRules := With[{z = 1, au = Automatic}, 
  {{{n_ /; Mod[n, 3] == 0, rgb_}, pos_} :> Inset[Graphics@{rgb, Disk[]}, pos, {-1, -1}, z], 
  {{n_ /; Mod[n, 3] == 1, rgb_}, pos_} :> Inset[Graphics@{rgb, Rectangle[]}, pos, {0, 0}, z], 
  {{n_ /; Mod[n, 3] == 2, rgb_}, pos_} :> Inset[Graphics@{Orange, Rectangle[]}, pos, {0, 0}, z]}
 ]

---

• "Do you have a better idea?"

I'm glad you asked; sure, I have a thought or two.

All jokes aside, I don't think that what I'll present below is necessarily better and I also have a persistent feeling that it definitely is not as efficient as it could have been (there's a lot of Map's, for one thing); I just got excited with the \[Bullet] and figured I should give it a go. Just to give a hint of what I tried, in the following I'll present only output with Rectangle's and Circles because I didn't like how Triangle's and Parallelogram's looked, but they worked too so anyone interested can try them out for themselves.

The palette

This is the palette. We'll be using it to provide (reproducible and random) custom color for our shapes.

With[{f = Rescale /* Mean, keys = {"Index", "Gradient", "Function"}, seed = RandomInteger[{10^5, 10^6}]},
  palette[nGradients_, seeding_: seed] := Module[{grads, fAssembleRow, dts, fSel},
    BlockRandom[grads = RandomChoice[ColorData["Gradients"], nGradients],    RandomSeeding -> seeding];
    fAssembleRow = Join[#2, {#1, f /* ColorData[#1, "ColorFunction"]}] &;
    dts = MapIndexed[AssociationThread[keys -> fAssembleRow[##]] &, grads] // Dataset;
    fSel[jSelect_] = Query[Select[#Index == jSelect &], "Function"] /* Normal /* First;
    <|"Data" -> dts, "Selector" -> (fSel[#] &), "Seed" -> seed|>
   ]
 ]

colorize is the interface to out palette:

colorize[palette_, iSelect_] := palette["Data"] // palette["Selector"][iSelect]

For example, pal = palette[3, 123456789] is equipped with three random "Gradients" "ColorFunction"'s from ColorData and evaluates to:

Also, fCol = pal // colorize[\[Bullet], 1]; retrieves the first "Gradient" "ColorFunction" and stores it in fCol; the following example uses a randomly generated $3 \times 3$ real matrix to display how colorize is used to paint three Disks's.

BlockRandom[RandomReal[{0, 10}, {3, 3}], RandomSeeding -> 123654789] //
  Map[fCol[\[Bullet]] /* {\[Bullet], Disk[]} /* Graphics] // Row

The main Dataset (that will be used throughout)

I find it useful to work with Dataset's that have column headers. In what follows, dts will be transformed with various operations in order to obtain the desired result.

dts = files // Map[("full" -> \[Bullet]) /* Association] /* Dataset;

The rest of the code

encode[hash_][base_, len_] = Map[Hash[\[Bullet], hash] /* IntegerDigits[\[Bullet], base, len]];

With[{paltt = palette[2, 123654987]},
  post[take_][tuples_][j_] := Map[Take[\[Bullet], take] /* 
    BlockMap[(paltt // colorize[\[Bullet], j]), \[Bullet], tuples]]
 ];

postproc[hash_][base_, len_][take_][tuples_][j_] := StringSplit[\[Bullet], "\\" | "."] /* 
  encode[hash][base, len] /* post[take][tuples][j];

preproc[td_] := <|"path" -> (FileNameDrop[#full, td] &), 
 "name" -> (FileNameTake[#full, td] &), "full" -> (#full &)|>;

shapes = {Rectangle[], Disk[]};

assortment[n_] := ap[{\[Bullet], RandomChoice[shapes, n]} /* Transpose /* 
  Map[Graphics] /* Column /* Rasterize]

queryNames[hash_][base_, len_][take_][tuples_][j_] := 
  Query[GroupBy["path"], KeyDrop["path"], {"name" -> 
    postproc[hash][base, len][take][tuples][j] /* assortment[4]}];

consolidate[hash_][base_, len_][take_][tuples_][j_] := Function[{path, list}, 
  Map[Join[<|"path" -> (path // postproc[hash][base, len][take][tuples][j] //             
    assortment[4])|>, \[Bullet]], list]];

queryPaths[hash_][base_, len_][take_][tuples_][j_] := Query[
  KeyValueMap[consolidate[hash][base, len][take][tuples][j] /* Apply[Sequence]]];

iconize = ImageRotate[\[Bullet], Pi/2] /* 
  Show[\[Bullet], ImageSize -> {70, 30}, PlotRange -> {{0, 10}, All},  AspectRatio -> 1/3];

join = <|"idicon" -> (ImageCollage[Join[#path, #name], Method -> "Rows", 
  ImageSize -> {60, 30}] &), "full" -> (#full &)|>;

The output

Using the files provided in the question, we obtain:

dts // Query[All, preproc[-1]] /* queryNames["MD5"][8, 36][12][3][2] /*
  queryPaths["MD5"][8, 36][12][3][1] /* Query[All, join]