[R] measuring distances between colours?
John Fox
jfox at mcmaster.ca
Sun Jun 2 20:03:29 CEST 2013
Dear Kevin,
When computer code is bug free, we'll probably all be out of business. Thank
you for improving my original code.
Best,
John
> -----Original Message-----
> From: r-help-bounces at r-project.org [mailto:r-help-bounces at r-
> project.org] On Behalf Of Kevin Wright
> Sent: Sunday, June 02, 2013 10:43 AM
> To: John Fox
> Cc: r-help; Michael Friendly; Martin Maechler
> Subject: Re: [R] measuring distances between colours?
>
> 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 at 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 at r-project.org [mailto:r-help-bounces at 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 at r-project.org [mailto:r-help-bounces at 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 at 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 at 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 at 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]]
>
> ______________________________________________
> R-help at 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.
More information about the R-help
mailing list