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-boun...@r-project.org [mailto:r-help-bounces@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 <j...@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-boun...@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-boun...@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]] > > ______________________________________________ > 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.
