I covered the mathematics of color matching in the VBA implementation in Find nearest color match. This is the Google Apps Script implementation. I’ll be using the CIEDE2000 algorithm to measure the distance between colors.
One thing I discovered was that GAS is rather slow compared to plain javaScript or VBA for these compute intensive tasks so I can achieve a lot less before I run out of allocated compute time.
The source and data are the heatMap workbook described in Playing around with GAS color, and much use is made of a shared library, see – Using the mcpher library in your code
Color Table matching
In Looking up color table I’ve built up a table of schemes such as Pantone, dulux etc through various web scraping sessions, and now have getting on for 10,000 named colors in that library. Here’s the GAS attempt at finding the closest matches to some random colors in a couple of the color schemes.
The gory details
These are implemented in Playing around with GAS color. Here’s the color match algorithm section.
Private Function computeH(a As Double, b As Double) As Double
If (a = 0 And b = 0) Then
computeH = 0
ElseIf (b >= 0) Then
computeH = Application.WorksheetFunction.Degrees(Application.WorksheetFunction.Atan2(a, b))
Else
computeH = Application.WorksheetFunction.Degrees(Application.WorksheetFunction.Atan2(a, b)) + 360
End If
End Function
Public Function cieDe2000(p1 As colorProps, p2 As colorProps) As Double
' calculates the distance between 2 colors using CIEDE200
' see http://www.ece.rochester.edu/~gsharma/cieDe2000/cieDe2000noteCRNA.pdf
Dim c1 As Double, c2 As Double, _
c As Double, g As Double, a1 As Double, b1 As Double, _
a2 As Double, b2 As Double, c1Tick As Double, c2Tick As Double, _
h1 As Double, h2 As Double, dh As Double, dl As Double, dc As Double, _
lTickAvg As Double, cTickAvg As Double, hTickAvg As Double, l50 As Double, sl As Double, _
sc As Double, t As Double, sh As Double, dTheta As Double, kp As Double, _
rc As Double, kl As Double, kc As Double, kh As Double, dlk As Double, _
dck As Double, dhk As Double, rt As Double, dBigH As Double
kp = 25 ^ 7
kl = 1
kc = 1
kh = 1
' calculate c & g values
c1 = Sqr(p1.aStar ^ 2 + p1.bStar ^ 2)
c2 = Sqr(p2.aStar ^ 2 + p2.bStar ^ 2)
c = (c1 + c2) / 2
g = 0.5 * (1 - Sqr(c ^ 7 / (c ^ 7 + kp)))
' adjusted ab*
a1 = (1 + g) * p1.aStar
a2 = (1 + g) * p2.aStar
' adjusted cs
c1Tick = Sqr(a1 ^ 2 + p1.bStar ^ 2)
c2Tick = Sqr(a2 ^ 2 + p2.bStar ^ 2)
' adjusted h
h1 = computeH(a1, p1.bStar)
h2 = computeH(a2, p2.bStar)
' deltas
If (h2 - h1 > 180) Then '1
dh = h2 - h1 - 360
ElseIf (h2 - h1 < -180) Then ' 2
dh = h2 - h1 + 360
Else '0
dh = h2 - h1
End If
dl = p2.LStar - p1.LStar
dc = c2Tick - c1Tick
dBigH = (2 * Sqr(c1Tick * c2Tick) * sIn(toRadians(dh / 2)))
' averages
lTickAvg = (p1.LStar + p2.LStar) / 2
cTickAvg = (c1Tick + c2Tick) / 2
If (c1Tick * c2Tick = 0) Then '3
hTickAvg = h1 + h2
ElseIf (Abs(h2 - h1) <= 180) Then '0
hTickAvg = (h1 + h2) / 2
ElseIf (h2 + h1 < 360) Then '1
hTickAvg = (h1 + h2) / 2 + 180
Else '2
hTickAvg = (h1 + h2) / 2 - 180
End If
l50 = (lTickAvg - 50) ^ 2
sl = 1 + (0.015 * l50 / Sqr(20 + l50))
sc = 1 + 0.045 * cTickAvg
t = 1 - 0.17 * Cos(toRadians(hTickAvg - 30)) + 0.24 * _
Cos(toRadians(2 * hTickAvg)) + 0.32 * _
Cos(toRadians(3 * hTickAvg + 6)) - 0.2 * _
Cos(toRadians(4 * hTickAvg - 63))
sh = 1 + 0.015 * cTickAvg * t
dTheta = 30 * Exp(-1 * ((hTickAvg - 275) / 25) ^ 2)
rc = 2 * Sqr(cTickAvg ^ 7 / (cTickAvg ^ 7 + kp))
rt = -sIn(toRadians(2 * dTheta)) * rc
dlk = dl / sl / kl
dck = dc / sc / kc
dhk = dBigH / sh / kh
cieDe2000 = Sqr(dlk ^ 2 + dck ^ 2 + dhk ^ 2 + rt * dck * dhk)
End Function
Private Function rgbToLab(rgbColor As Long) As colorProps
' adapted from // http://www.easyrgb.com/
Dim x As Double, y As Double, z As Double, _
p As colorProps
p = rgbToXyz(rgbColor)
x = xyzCIECorrection(p.x / refWhiteX)
y = xyzCIECorrection(p.y / refWhiteY)
z = xyzCIECorrection(p.z / refWhiteZ)
p.LStar = (116 * y) - 16
p.aStar = 500 * (x - y)
p.bStar = 200 * (y - z)
rgbToLab = p
End Function
Private Function rgbToXyz(rgbColor As Long) As colorProps
' adapted from // http://www.easyrgb.com/
Dim r As Double, g As Double, b As Double, _
p As colorProps
r = xyzCorrection(rgbRed(rgbColor) / 255) * 100
g = xyzCorrection(rgbGreen(rgbColor) / 255) * 100
b = xyzCorrection(rgbBlue(rgbColor) / 255) * 100
p.x = r * 0.4124 + g * 0.3576 + b * 0.1805
p.y = r * 0.2126 + g * 0.7152 + b * 0.0722
p.z = r * 0.0193 + g * 0.1192 + b * 0.9505
rgbToXyz = p
End Function
Private Function xyzCIECorrection(v As Double) As Double
If (v > 0.008856) Then
xyzCIECorrection = (v ^ (1 / 3))
Else
xyzCIECorrection = (7.787 * v) + (16 / 116)
End If
End Function
Private Function xyzCorrection(v As Double) As Double
If (v > 0.04045) Then
xyzCorrection = ((v + 0.055) / 1.055) ^ 2.4
Else
xyzCorrection = v / 12.92
End If
End Function
and here’ the test procedure that generated the above
Public Function compareColors(rgb1 As Long, rgb2 As Long, _
Optional compareType As eCompareColor = eCompareColor.eccieDe2000) As Double
Dim p1 As colorProps, p2 As colorProps
p1 = makeColorProps(rgb1)
p2 = makeColorProps(rgb2)
Select Case compareType
Case eCompareColor.eccieDe2000
compareColors = cieDe2000(p1, p2)
Case Else
Debug.Assert False
End Select
End Function
More color related topics? Return to VBA to Apps Script topics here