Color Matching in GAS

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