Sorry about the bug. How embarrassing. Especially because I've learned over
the years to trust my gut feelings when something doesn't feel quite right,
and when I was testing the function, I remember thinking "surely there a
better matching named color than 'magenta'".

Thanks for the fix.

Kevin



On Sat, Jun 1, 2013 at 11:30 AM, John Fox <jfox@mcmaster.ca> wrote:

> Hi Michael,
>
> This has become a bit of a comedy of errors.
>
> The bug is in Kevin Wright's code, which I adapted, and you too in your
> version, which uses local() rather than function() to produce the closure.
> The matrix which.col contains character data, as a consequence of binding
> the minimum squared distances to colour names, and thus the comparison
> cols.near[2,] < near^2 doesn't work properly when, ironically, the distance
> is small enough so that it's rendered in scientific notation.
>
> Converting to numeric appears to work:
>
> > rgb2col2 <- local({
> +     all.names <- colors()
> +     all.hsv <- rgb2hsv(col2rgb(all.names))
> +     find.near <- function(x.hsv) {
> +         # return the nearest R color name and distance
> +         sq.dist <- colSums((all.hsv - x.hsv)^2)
> +         rbind(all.names[which.min(sq.dist)], min(sq.dist))
> +     }
> +     function(cols.hex, near=.25){
> +         cols.hsv <- rgb2hsv(col2rgb(cols.hex))
> +         cols.near <- apply(cols.hsv, 2, find.near)
> +         ifelse(as.numeric(cols.near[2,]) <= near^2, cols.near[1,],
> cols.hex)
> +     }
> + })
>
> > rgb2col2(c("#010101", "#EEEEEE", "#AA0000", "#00AA00", "#0000AA",
> +     "#AAAA00", "#AA00AA", "#00AAAA"))
>
> [1] "black"         "gray93"        "darkred"       "green4"        "blue4"
> "darkgoldenrod"
> [7] "darkmagenta"   "cyan4"
>
> The same bug is in the code that I just posted using Lab colours, so (for
> posterity) here's a fixed version of that, using local():
>
> > rgb2col <- local({
> +     all.names <- colors()
> +     all.lab <- t(convertColor(t(col2rgb(all.names)), from = "sRGB",
> +         to = "Lab", scale.in = 255))
> +     find.near <- function(x.lab) {
> +         sq.dist <- colSums((all.lab - x.lab)^2)
> +         rbind(all.names[which.min(sq.dist)], min(sq.dist))
> +     }
> +     function(cols.hex, near = 2.3) {
> +         cols.lab <- t(convertColor(t(col2rgb(cols.hex)), from = "sRGB",
> +             to = "Lab", scale.in = 255))
> +         cols.near <- apply(cols.lab, 2, find.near)
> +         ifelse(as.numeric(cols.near[2, ]) < near^2, cols.near[1, ],
> toupper(cols.hex))
> +     }
> + })
>
> > rgb2col(c("#010101", "#EEEEEE", "#AA0000", "#00AA00", "#0000AA",
> "#AAAA00", "#AA00AA", "#00AAAA"))
>
> [1] "black"   "gray93"  "#AA0000" "#00AA00" "#0000AA" "#AAAA00"
> [7] "#AA00AA" "#00AAAA"
>
> > rgb2col(c("#010101", "#EEEEEE", "#AA0000", "#00AA00", "#0000AA",
> "#AAAA00", "#AA00AA", "#00AAAA"), near=15)
>
> [1] "black"         "gray93"        "firebrick3"    "limegreen"
> [5] "blue4"         "#AAAA00"       "darkmagenta"   "lightseagreen"
>
> So with Lab colours, setting near to the JND of 2.3 leaves many of these
> colours unmatched. I experimented a bit, and using 15 (as above) produces
> matches that appear reasonably "close" to me.
>
> I used squared distances to avoid taking the square-roots of all the
> distances. Since the criterion for "near" colours, which is on the distance
> scale, is squared to make the comparison, this shouldn't be problematic.
>
> I hope that finally this will be a satisfactory solution.
>
> Best,
>  John
>
> > -----Original Message-----
> > From: r-help-bounces@r-project.org [mailto:r-help-bounces@r-
> > project.org] On Behalf Of Michael Friendly
> > Sent: Saturday, June 01, 2013 11:33 AM
> > To: John Fox
> > Cc: 'r-help'; 'Martin Maechler'
> > Subject: Re: [R] measuring distances between colours?
> >
> > Just a quick note:  The following two versions of your function don't
> > give the same results.  I'm not sure why, and also not sure why the
> > criterion for 'near' should be expressed in squared distance.
> >
> > # version 1
> > rgb2col <- local({
> >      hex2dec <- function(hexnums) {
> >          # suggestion of Eik Vettorazzi
> >          sapply(strtoi(hexnums, 16L), function(x) x %/% 256^(2:0) %%
> > 256)
> >      }
> >      findMatch <- function(dec.col) {
> >          sq.dist <- colSums((hsv - dec.col)^2)
> >          rbind(which.min(sq.dist), min(sq.dist))
> >      }
> >      colors <- colors()
> >      hsv <- rgb2hsv(col2rgb(colors))
> >
> >      function(cols, near=0.25) {
> >          cols <- sub("^#", "", toupper(cols))
> >          dec.cols <- rgb2hsv(hex2dec(cols))
> >          which.col <- apply(dec.cols, 2, findMatch)
> >          matches <- colors[which.col[1, ]]
> >          unmatched <- which.col[2, ] > near^2
> >          matches[unmatched] <- paste("#", cols[unmatched], sep="")
> >          matches
> >      }
> > })
> >
> > # version 2
> > rgb2col2 <- local({
> >        all.names <- colors()
> >        all.hsv <- rgb2hsv(col2rgb(all.names))
> >        find.near <- function(x.hsv) {
> >            # return the nearest R color name and distance
> >            sq.dist <- colSums((all.hsv - x.hsv)^2)
> >            rbind(all.names[which.min(sq.dist)], min(sq.dist))
> >        }
> >        function(cols.hex, near=.25){
> >            cols.hsv <- rgb2hsv(col2rgb(cols.hex))
> >            cols.near <- apply(cols.hsv, 2, find.near)
> >            ifelse(cols.near[2,] < near^2, cols.near[1,], cols.hex)
> >        }
> > })
> >
> > # tests
> >  > rgb2col(c("#010101", "#EEEEEE", "#AA0000", "#00AA00", "#0000AA",
> > "#AAAA00", "#AA00AA", "#00AAAA"))
> > [1] "black"         "gray93"        "darkred"       "green4"
> > [5] "blue4"         "darkgoldenrod" "darkmagenta"   "cyan4"
> >  > rgb2col2(c("#010101", "#EEEEEE", "#AA0000", "#00AA00", "#0000AA",
> > "#AAAA00", "#AA00AA", "#00AAAA"))
> > [1] "#010101"       "#EEEEEE"       "darkred"       "green4"
> > [5] "blue4"         "darkgoldenrod" "darkmagenta"   "cyan4"
> >  >
> >
> >
> > On 5/31/2013 7:42 PM, John Fox wrote:
> > > Dear Kevin,
> > >
> > > I generally prefer your solution. I didn't realize that col2rgb()
> > worked
> > > with hex-colour input (as opposed to named colours), so my code
> > converting
> > > hex numbers to decimal is unnecessary; and using ifelse() is clearer
> > than
> > > replacing the non-matches.
> > >
> > > I'm not so sure about avoiding the closure, since for converting
> > small
> > > numbers of colours, your function will spend most of its time
> > constructing
> > > the local function find.near() and building all.hsv. Here's an
> > example,
> > > using your rgb2col() and a comparable function employing a closure,
> > with one
> > > of your examples executed 100 times:
> > >
> > >> r2c <- function(){
> > > +     all.names <- colors()
> > > +     all.hsv <- rgb2hsv(col2rgb(all.names))
> > > +     find.near <- function(x.hsv) {
> > > +         # return the nearest R color name and distance
> > > +         sq.dist <- colSums((all.hsv - x.hsv)^2)
> > > +         rbind(all.names[which.min(sq.dist)], min(sq.dist))
> > > +     }
> > > +     function(cols.hex, near=.25){
> > > +         cols.hsv <- rgb2hsv(col2rgb(cols.hex))
> > > +         cols.near <- apply(cols.hsv, 2, find.near)
> > > +         ifelse(cols.near[2,] < near^2, cols.near[1,], cols.hex)
> > > +     }
> > > + }
> > >
> > >> mycols <- c("#010101", "#EEEEEE", "#AA0000", "#00AA00", "#0000AA",
> > > +     "#AAAA00", "#AA00AA", "#00AAAA")
> > >
> > >> system.time(for (i in 1:100) oldnew <- c(mycols, rgb2col(mycols,
> > > near=.25)))
> > >     user  system elapsed
> > >     1.97    0.00    1.97
> > >
> > >> system.time({rgb2col2 <- r2c()
> > > +     for (i in 1:100) oldnew2 <- c(mycols, rgb2col2(mycols,
> > near=.25))
> > > +     })
> > >     user  system elapsed
> > >     0.08    0.00    0.08
> > >
> > >> rbind(oldnew, oldnew2)
> > >          [,1]      [,2]      [,3]      [,4]      [,5]      [,6]
> > > oldnew  "#010101" "#EEEEEE" "#AA0000" "#00AA00" "#0000AA" "#AAAA00"
> > > oldnew2 "#010101" "#EEEEEE" "#AA0000" "#00AA00" "#0000AA" "#AAAA00"
> > >          [,7]      [,8]      [,9]      [,10]     [,11]     [,12]
> > > oldnew  "#AA00AA" "#00AAAA" "#010101" "#EEEEEE" "darkred" "green4"
> > > oldnew2 "#AA00AA" "#00AAAA" "#010101" "#EEEEEE" "darkred" "green4"
> > >          [,13]   [,14]           [,15]         [,16]
> > > oldnew  "blue4" "darkgoldenrod" "darkmagenta" "cyan4"
> > > oldnew2 "blue4" "darkgoldenrod" "darkmagenta" "cyan4"
> > >
> > > Does this really make a difference? Frankly, it wouldn't for my
> > application
> > > (for colour selection in the Rcmdr) where a user is likely to perform
> > at
> > > most one or two conversions of a small number of colours in a
> > session. The
> > > time advantage of the second approach will depend upon the number of
> > times
> > > the function is invoked and the number of colours converted each
> > time.
> > >
> > > Best,
> > >   John
> > >
> > >> -----Original Message-----
> > >> From: r-help-bounces@r-project.org [mailto:r-help-bounces@r-
> > >> project.org] On Behalf Of Kevin Wright
> > >> Sent: Friday, May 31, 2013 3:39 PM
> > >> To: Martin Maechler
> > >> Cc: r-help; John Fox
> > >> Subject: Re: [R] measuring distances between colours?
> > >>
> > >> Thanks for the discussion.  I've also wanted to be able to find
> > nearest
> > >> colors.  I took the code and comments in this thread and simplified
> > the
> > >> function even further.  (Personally, I think using closures results
> > in
> > >> Rube-Goldberg code.  YMMV.)  The first example below is what I use
> > for
> > >> 'group' colors in lattice.
> > >>
> > >> Kevin Wright
> > >>
> > >> rgb2col <- function(cols.hex, near=.25){
> > >>    # Given a vector of hex colors, find the nearest 'named' R colors
> > >>    # If no color closer than 'near' is found, return the hex color
> > >>    # Authors: John Fox, Martin Maechler, Kevin Wright
> > >>    # From r-help discussion 5.30.13
> > >>
> > >>    find.near <- function(x.hsv) {
> > >>      # return the nearest R color name and distance
> > >>      sq.dist <- colSums((all.hsv - x.hsv)^2)
> > >>      rbind(all.names[which.min(sq.dist)], min(sq.dist))
> > >>    }
> > >>    all.names <- colors()
> > >>    all.hsv <- rgb2hsv(col2rgb(all.names))
> > >>    cols.hsv <- rgb2hsv(col2rgb(cols.hex))
> > >>    cols.near <- apply(cols.hsv, 2, find.near)
> > >>    ifelse(cols.near[2,] < near^2, cols.near[1,], cols.hex)
> > >> }
> > >>
> > >> mycols <- c("royalblue", "red", "#009900", "dark orange", "#999999",
> > >> "#a6761d", "#aa00da")
> > >> mycols <- c("#010101", "#EEEEEE", "#AA0000", "#00AA00", "#0000AA",
> > >> "#AAAA00", "#AA00AA", "#00AAAA")
> > >> mycols <- c("#010101", "#090909", "#090000", "#000900", "#000009",
> > >> "#090900", "#090009", "#000909")
> > >> oldnew <- c(mycols, rgb2col(mycols, near=.25)) # Also try near=10
> > >> pie(rep(1,2*length(mycols)), labels=oldnew, col=oldnew)
> > >>
> > >>    [[alternative HTML version deleted]]
> > >>
> > >> ______________________________________________
> > >> R-help@r-project.org mailing list
> > >> https://stat.ethz.ch/mailman/listinfo/r-help
> > >> PLEASE do read the posting guide http://www.R-project.org/posting-
> > >> guide.html
> > >> and provide commented, minimal, self-contained, reproducible code.
> > >
> >
> >
> > --
> > Michael Friendly     Email: friendly AT yorku DOT ca
> > Professor, Psychology Dept. & Chair, Quantitative Methods
> > York University      Voice: 416 736-2100 x66249 Fax: 416 736-5814
> > 4700 Keele Street    Web:   http://www.datavis.ca
> > Toronto, ONT  M3J 1P3 CANADA
> >
> > ______________________________________________
> > R-help@r-project.org mailing list
> > https://stat.ethz.ch/mailman/listinfo/r-help
> > PLEASE do read the posting guide http://www.R-project.org/posting-
> > guide.html
> > and provide commented, minimal, self-contained, reproducible code.
>
> ______________________________________________
> R-help@r-project.org mailing list
> https://stat.ethz.ch/mailman/listinfo/r-help
> PLEASE do read the posting guide
> http://www.R-project.org/posting-guide.html
> and provide commented, minimal, self-contained, reproducible code.
>



-- 
Kevin Wright

	[[alternative HTML version deleted]]

