Inverse of Interpreter["Color"]: Convert a RGBColor to a natural language color name

Question

What is the best way to create the inverse function of Interpreter["Color"]? That function takes a natural language color name like "blue" as input, and returns an RGBColor as output.

Here I whipped up a basic classifier based on Mathematica's built-in color symbols:

trainingset = 
  (List @@ ColorConvert[Symbol@#, "RGB"] -> #) & /@ 
  StringSplit[
    "Red,Green,Blue,Black,White,Gray,Cyan,Magenta,Yellow,Brown,Orange,Pink,Purple", ","]

testset = {
  RGBColor[0., 0., 0., 0.],         RGBColor[0., 0., 0., 1.], 
  RGBColor[0., 0.2196, 0.7215, 1.], RGBColor[0., 0.4235, 0.2078, 1.], 
  RGBColor[0., 0.4784, 0.2392, 1.], RGBColor[0.8078, 0.0666, 0.1490, 1.],
  RGBColor[1., 1., 1., 1.],         RGBColor[1., 0.8705, 0., 1.],
  RGBColor[0.2039, 0.6980, 0.2, 1.],RGBColor[0.0039, 0., 0.4, 1.]
}

c = Classify[trainingset]

c /@ Take[#, 3] & /@ (List @@ ColorConvert[#, "RGB"] & /@ testset)

(*
  {"Black", "Black", "Blue", "Black", "Green", "Red", "White", "Yellow", "Green", "Black"}
*)

I'm not sure how well it works in general, but the darker colors seem to come out as "Black".

Answer 1

This could provide a good starting point:

First step is to provide multiple examples of "red", "blue", etc for the training set. I found a site that had some convenient images for this task. For example a good sample of "reds":

So I import the images:

images = Import[
   "http://ingridsundberg.com/2014/02/04/the-color-thesaurus/", 
   "Images"][[2 ;; 13]];

assign some labels:

names = {"white", "tan", "yellow", "orange", "red", "pink", "purple", 
         "blue", "green", "brown", "gray", "black"}

pull out the "dominant" colors:

colors=DominantColors[#, 20, ColorCoverage -> 1/30, MinColorDistance -> 0] & /@ images;

and then train (but first I remove the RGBColor head as I had some difficulties passing RGBColor[r,g,b] directly to Classify)

training = Apply[List,colors,2];
cf = Classify[<|Thread[names -> training]|>];

from there I get some decent results:

cf[List @@ Brown]
(* "brown" *)

cf[List @@ Orange]
(* "orange" *)

cf[{0.1, 0.25, 0}]
(* "green" *)

Manipulate[cf[List @@ color], {color, Red}]

Answer 2

One way is to ask WolframAlpha, but it can be slow and requires internet connectivity.

NearestHTMLColorNames[color_] := Rest[WolframAlpha[
  StringDelete[ToString[ColorConvert[color, "RGB"]], "Color"],
  {{"NearestNamedHTML:ColorData", 1}, "ComputableData"}, 
   PodStates -> {"NearestNamedHTML:ColorData__More"}]][[All, 2]]

NearestHTMLColorNames[RGBColor[0, 0, 1]]

{"blue", "medium blue", "dark blue", "navy", "dodger blue", "blue violet"}

This problem was a lot harder than I anticipated! The reason being, the closest distance in Euclidean space does not necessarily mean two colors will look the same.

The idea I has was to look at color's positions in a 3D chromaticity plot and grab the nearest named color to it. The results are ok...

(* my list of names *)
names = {"white", "tan", "yellow", "orange", "red", "pink", "purple", "blue", "green", "brown", "gray", "black", "turquoise"};

(* find their values *)
colors = Interpreter["Color"][#] -> # & /@ names

(* allow lighter and darker variants as well *)
colors = Join @@ (If[MatchQ[#2, "white" | "black"], {#1 -> #2}, 
 {Lighter[#1] -> #2, #1 -> #2, Darker[#1] -> #2}] & @@@ colors)

(* find the location of these colors in ChromaticityPlot3D *)
chromaticitylocations = Rule @@@ Reverse /@ 
 Partition[ChromaticityPlot3D[colors[[All, 1]]][[1, 2]], 2] /. 
  Point -> Identity /. c_?ColorQ :> First[Nearest[colors, c]];

(* create our function using Nearest *)
With[{nf = Nearest[chromaticitylocations]},
  NearestColorName[color_] := First[nf[FirstCase[
   ChromaticityPlot3D[color], Point[p_] :> p, _, ∞]]]
]

Now we test and see the results aren't terrible.

{#, NearestColorName[#]} & /@ RandomColor[40]

We can see the main issue is gray... Probably a simple way to improve this is to use a larger named color bank.

Answer 3

As nobody mentioned it, there is a "Named" ColorData called "HTML that gives (a subset?) of the HTML colors.

Short[ColorData["HTML", "ColorRules"], 2]

It takes nothing to build a NearestFunction from that.

SetAttributes[NearestHTMLColorNames, Listable]

NearestHTMLColorNames[color_?ColorQ] :=
 With[{nf = Nearest[Map[Reverse, ColorData["HTML", "ColorRules"]]]},
  First[nf[color], Missing[]]
 ]

And that apply that to a list of colors

{#, NearestHTMLColorNames[#]} &@RandomColor[12] // Transpose // Grid