[Rd] [FORGED] Possible bug with chromatic adaptation in grDevices::convertColor

[Paul Murrell]

Thanks for the report (and the bug report).
I need to make time to have a closer look at this.

Paul

On 14/09/18 14:03, brodie gaslam via R-devel wrote:
> It appears that the chromatic adaptation feature of `grDevices::convertColor`is broken, and likely has been for many years.  While a little surprising, it is an obscure enough feature that there is some possibility this is actually broken, as opposed to user error on my part.  If it turns out to the latter, I apologize in advance for spamming this list.
> Consider:
>      rgb.in <- c("#CCCCCC", "#EEEEEE")    clr <- t(col2rgb(rgb.in)) / 255    clr.out <- convertColor(clr, "sRGB", "sRGB")    rgb(clr.out)    ## [1] "#CCCCCC" "#EEEEEE"
>      convertColor(clr, "sRGB", "sRGB", "D65", "D50")    ## Error in match.arg(from, nWhite) :    ##   'arg' must be NULL or a character vector
> This appears to be because `grDevices:::chromaticAdaptation` expects the whitepoints to be provided in the character format (e.g. "D65"), but they are already converted by `convertColor` into the tristimulus values.  After applying the patch at the end of this e-mail, we get:
>      clr.out <- convertColor(clr, "sRGB", "sRGB", "D65", "D50")    rgb(clr.out)    ## [1] "#DACAB0" "#FEECCE"
> I do not have a great way of confirming that the conversion is correct with my changes, but I did verify that the `M` matrix computed within`grDevics:::chromaticAdaptation` for the "D65"->"D50" conversion (approximately) matches the corresponding matrix from brucelindbloom.com chromatic adaptation page:
> http://www.brucelindbloom.com/Eqn_ChromAdapt.html
> Additionally visual inspection via
>       scales::show_col(c(rgb.in, rgb(clr.out)))
> is consistent with a shift from bluer indirect daylight ("D65") to yellower direct daylight ("D50") illuminant.
> It is worth noting that the adaption method currently in`grDevices:::chromaticAdaptation` appears to be the "Von Kries" method, not the "Bradford" method as documented in `?convertColor` and in the comments of thesources.  I base this on comparing the cone response domain matrices on the aforementioned brucelindbloom.com page to the `Ma` matrix defined in`grDevics:::chromaticAdaptation`.
> Given that brucelindbloom.com appears to recommend "Bradford", that the sources suggest that was the intent, that `chromaticAdaptation` is only used by`convertColor` in the R sources, that `chromaticAdapation` is not exported, and that that feature appears currently inaccessible via `convertColor`, it may be worth using this opportunity to change the adaptation method to "Bradford".
> A suggested patch follows.  It is intended to minimize the required changes, although doing so requires a double transposition.  The transpositions could be easily avoided, but it would require reformulating the calculations in`chromaticAdaption`.
> Best,
> Brodie.
> 
> Index: src/library/grDevices/R/convertColor.R
> ===================================================================
> --- src/library/grDevices/R/convertColor.R    (revision 75298)
> +++ src/library/grDevices/R/convertColor.R    (working copy)
> @@ -81,7 +81,7 @@
>   }
>   
>   chromaticAdaptation <- function(xyz, from, to) {
> -    ## bradford scaling algorithm
> +    ## Von Kries scaling algorithm
>       Ma <- matrix(c( 0.40024, -0.22630, 0.,
>                       0.70760,  1.16532, 0.,
>                      -0.08081,  0.04570, 0.91822), nrow = 3L, byrow = TRUE)
> @@ -242,8 +242,8 @@
>     if (is.null(from.ref.white))
>         from.ref.white <- to.ref.white
>   
> -  from.ref.white <- c2to3(white.points[, from.ref.white])
> -  to.ref.white   <- c2to3(white.points[, to.ref.white])
> +  from.ref.white.3 <- c2to3(white.points[, from.ref.white])
> +  to.ref.white.3   <- c2to3(white.points[, to.ref.white])
>   
>     if (is.null(nrow(color)))
>       color <- matrix(color, nrow = 1L)
> @@ -262,19 +262,19 @@
>         rgb
>     }
>   
> -  xyz <- apply(color, 1L, from$toXYZ, from.ref.white)
> +  xyz <- apply(color, 1L, from$toXYZ, from.ref.white.3)
>   
>     if (is.null(nrow(xyz)))
>       xyz <- matrix(xyz, nrow = 1L)
>   
> -  if (!isTRUE(all.equal(from.ref.white, to.ref.white))) {
> +  if (!isTRUE(all.equal(from.ref.white.3, to.ref.white.3))) {
>         mc <- match.call()
>         if (is.null(mc$from.ref.white) || is.null(mc$to.ref.white))
>             warning("color spaces use different reference whites")
> -      xyz <- chromaticAdaptation(xyz, from.ref.white, to.ref.white)
> +      xyz <- t(chromaticAdaptation(t(xyz), from.ref.white, to.ref.white))
>     }
>   
> -  rval <- apply(xyz, 2L, to$fromXYZ, to.ref.white)
> +  rval <- apply(xyz, 2L, to$fromXYZ, to.ref.white.3)
>   
>     if (inherits(to,"RGBcolorConverter"))
>         rval <- trim(rval)
> 
> 
> 
> 
> 	[[alternative HTML version deleted]]
> 
> ______________________________________________
> R-devel using r-project.org mailing list
> https://stat.ethz.ch/mailman/listinfo/r-devel
> 

-- 
Dr Paul Murrell
Department of Statistics
The University of Auckland
Private Bag 92019
Auckland
New Zealand
64 9 3737599 x85392
paul using stat.auckland.ac.nz
http://www.stat.auckland.ac.nz/~paul/