Playing around with heatmaps. http://ramblings.mcpher.com

heatmapExamples.vba

Option Explicit
' v2.06 -   5083132
Private Sub runMap()
    applyHeatMapToRange Range("sankey!e2:e41")
    
End Sub
Private Sub colorThemePlay()
    Dim r As Range, i As Long, j As Long, p As colorProps
    
    ' 1= background1, 2= text1, 3 = background2, 4 = text2, 5-10 accent1-6
    
    Set r = firstCell(wholeSheet("colorTheme"))
    Application.Calculation = xlCalculationManual
    For i = 1 To 10
        With r.Offset(1, i - 1)
            p = makeColorProps(.Interior.color)
            .value = p.htmlHex
            .Font.color = p.textColor
        End With
        With r.Offset(3, i - 1)
            For j = 1 To 5
                With .Offset(j - 1)
                    p = makeColorProps(.Interior.color)
                    .Font.color = p.textColor
                    .value = .Interior.TintAndShade
                End With
            Next j
            For j = 1 To 5
                p = makeColorProps(.Offset(j - 1).Interior.color)
                With .Offset(6 + j - 1)
                    .Interior.color = p.rgb
                    .Font.color = p.textColor
                    .value = p.htmlHex
                End With
                
            Next j

            For j = 1 To 5
                p = makeColorProps(.Offset(j - 1).Interior.color)
                With .Offset(12 + j - 1)
                    .Interior.color = p.rgb
                    .Font.color = p.textColor
                    .value = p.hue
                End With
            Next j
            
            For j = 1 To 5
                p = makeColorProps(.Offset(j - 1).Interior.color)
                With .Offset(18 + j - 1)
                    .Interior.color = p.rgb
                    .Font.color = p.textColor
                    .value = p.saturation
                End With
            Next j
            
            For j = 1 To 5
                p = makeColorProps(.Offset(j - 1).Interior.color)
                With .Offset(24 + j - 1)
                    .Interior.color = p.rgb
                    .Font.color = p.textColor
                    .value = p.lightness
                End With
            Next j
            
            For j = 1 To 5
                p = makeColorProps(.Offset(j - 1).Interior.color)
                With .Offset(30 + j - 1)
                    .Interior.color = p.rgb
                    .Font.color = p.textColor
                    .value = p.value
                End With
            Next j
            
            For j = 1 To 5
                p = makeColorProps(.Offset(j - 1).Interior.color)
                With .Offset(36 + j - 1)
                    .Interior.color = p.rgb
                    .Font.color = p.textColor
                    .value = p.aStar
                End With
            Next j
            
            For j = 1 To 5
                p = makeColorProps(.Offset(j - 1).Interior.color)
                With .Offset(42 + j - 1)
                    .Interior.color = p.rgb
                    .Font.color = p.textColor
                    .value = p.bStar
                End With
            Next j
            
            For j = 1 To 5
                p = makeColorProps(.Offset(j - 1).Interior.color)
                With .Offset(48 + j - 1)
                    .Interior.color = p.rgb
                    .Font.color = p.textColor
                    .value = p.cStar
                End With
            Next j
            
            For j = 1 To 5
                p = makeColorProps(.Offset(j - 1).Interior.color)
                With .Offset(54 + j - 1)
                    .Interior.color = p.rgb
                    .Font.color = p.textColor
                    .value = p.hStar
                End With
            Next j
            
        End With
    Next i
    Application.Calculation = xlCalculationAutomatic
End Sub


Private Sub checkit()
    Dim i As Long
    For i = vbBlack To vbWhite
        Debug.Assert i = lchToRgb(makeColorProps(i))
    Next i
    
End Sub
Public Sub getSomePalettes()
    Dim n As Long, r As Range, ncells As Long, p As colorProps, swatchSize As Long, _
        a() As colorProps, i As Long, models As Variant, prop As Variant, _
        done As Long, j As Long, k As Long, rowHeight As Double, spaceHeight As Double, _
        columnWidth As Double, spaceWidth As Double, rowOff As Long, colOff As Long, t As Long
        
    Set r = firstCell(wholeSheet("palette"))
    models = Array("lch", "hsl")
    prop = Array("hue", "lightness", "saturation")
    ncells = 9
    swatchSize = 5
    done = 0
    rowHeight = 20
    columnWidth = 6
    spaceHeight = rowHeight / 5
    spaceWidth = columnWidth / 5
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Randomize
    '--------create some random colors to test against, and format worksheet
    For n = 1 To ncells
        With r.Offset((n - 1) * (2 + arrayLength(models)) + 1, 0).Resize(arrayLength(models) + 1)
            ' basic section for this random color
            ''p = makeColorProps(Int((vbWhite - vbBlack + 1) * Rnd + vbBlack))
            p = makeColorProps(htmlHexToRgb(r.Offset(1 + (n - 1) * 4, 0).Resize(1, 1).value))
            .Interior.color = p.rgb
            .Font.color = p.textColor
            .value = Empty
            .rowHeight = rowHeight
            ' name the models
            For k = LBound(models) To UBound(models)
                .Resize(1, 1).Offset(k - LBound(models) + 1).value = models(k)
            Next k
            .Resize(arrayLength(models), 1).Offset(1).BorderAround xlContinuous
            
            ' add a break line with reference color
            With .Resize(1, arrayLength(prop) * (swatchSize + 1) + 1)
                .Interior.color = p.rgb
                .Font.color = p.textColor
                .columnWidth = columnWidth
                With .Resize(, 1)
                    .value = p.htmlHex
                    .columnWidth = columnWidth * 3
                End With
                .Offset(0, 0).BorderAround xlContinuous
            End With
            
            ' add column breaks between props and name them
            For k = LBound(prop) To UBound(prop)
                With .Resize(, 1).Offset(, 1 + (swatchSize + 1) * (k - LBound(prop)))
                    .columnWidth = spaceWidth
                    .Resize(1, 1).Offset(, 1).value = prop(k)
                End With
            Next k
            
            ' add a break line after
            With .Offset(arrayLength(models) + 1).Resize(1)
                .rowHeight = spaceHeight
                .Interior.color = vbWhite
                .Font.color = vbBlack
                .value = Empty
            End With
        End With
        
    Next n

    '------------create various palettes
    For k = LBound(models) To UBound(models)
        For j = LBound(prop) To UBound(prop)
            For n = 1 To ncells
                ' this is the header row/narrow column
                rowOff = 1 + (n - 1) * (2 + arrayLength(models))
                colOff = 1 + (1 + swatchSize) * (j - LBound(prop))
                With r.Offset(rowOff, colOff)
                    
                    a = makeAPalette(.Interior.color, CStr(models(k)), _
                                CStr(prop(j)), swatchSize)

                    With .Offset(k - LBound(models) + 1)
                        .Interior.color = vbWhite
                        For i = LBound(a) To UBound(a)
                            With .Offset(, 1 + i - LBound(a))
                                .Interior.color = a(i).rgb
                                .value = rgbToHTMLHex(a(i).rgb)
                            End With
                            .Offset(, 1).Resize(, swatchSize).BorderAround xlContinuous
                        Next i
                    End With
                
                End With
            Next n
        Next j
    Next k
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Public Function makeAPalette(rgbColor As Long, Optional model As String = "lch", _
        Optional iType As String = "hue", Optional howMany As Long = 5) As colorProps()
    ' return an array of palettable colors
    Dim g As Double, a() As colorProps, p As colorProps, _
        i As Long, h As Double, top As Double, pv As String
    ReDim a(1 To howMany)
    
    If iType = "hue" Then
        top = 360
    Else
        top = 100
    End If
    
    ' step
    g = top / howMany
    p = makeColorProps(rgbColor)
    
    If iType = "hue" Then
        If model = "lch" Then
            h = p.hStar
            pv = "hStar"
        Else
            h = p.hue
            pv = "hue"
        End If
    
    ElseIf iType = "saturation" Then
        If model = "lch" Then
            h = p.cStar
            pv = "cstar"
        Else
            h = p.saturation
            pv = "saturation"
        End If

    Else
        If model = "lch" Then
            h = p.LStar
            pv = "lstar"
        Else
            h = p.lightness
            pv = "lightness"
        End If
        
    End If
    
    For i = 1 To howMany
        If h > top Then h = h - top
        If model = "lch" Then
            If iType = "hue" Then
                p.hStar = h
            ElseIf iType = "saturation" Then
                p.cStar = h
            Else
                p.LStar = h
            End If
            p = makeColorProps(lchToRgb(p))
        Else
            If iType = "hue" Then
                p.hue = h
            ElseIf iType = "saturation" Then
                p.saturation = h
            Else
                p.lightness = h
            End If
            p = makeColorProps(hslToRgb(p))
        End If
        a(i) = p
        h = h + g

    Next i
    sortColorProp a, LBound(a), UBound(a), pv
    makeAPalette = a
End Function
Public Sub SeedSomeColors()
    Dim r As Range, n As Long, ncells As Long, ds As cDataSet, t As Long, dc As cCell, _
        dr As cDataRow, p As colorProps, a As Variant, i As Long
    Set r = firstCell(wholeSheet("comparecolors"))
    ncells = 30
    Application.Calculation = xlCalculationManual
    Randomize
    ' create some random colors to test against
    For n = 1 To ncells
        With r.Offset(n, 0)
            p = makeColorProps(Int((vbWhite - vbBlack + 1) * Rnd + vbBlack))
            .Interior.color = p.rgb
            .Font.color = p.textColor
            .value = p.htmlHex
        End With
    Next n

    ' now look in the colortable
    Set ds = getcolorMap()
    
    ' cycle through various schemes
    a = Array("", "pms", "pfh", "dulux", "htm")
    For i = LBound(a) To UBound(a)
        For n = 1 To ncells
            t = r.Offset(n, 0).Interior.color
            Set dc = getClosestColorMap(ds, t, CStr(a(i)))
            If Not dc Is Nothing Then
                With r.Offset(n, 1 + i - LBound(a))
                    p = makeColorProps(htmlHexToRgb(dc.value))
                    .value = ds.value(dc.row, "name")
                    .Interior.color = p.rgb
                    .Font.color = p.textColor
                End With
            End If
        Next n
    Next i
    

    Application.Calculation = xlCalculationAutomatic
    ds.tearDown
    
End Sub
Private Function getClosestColorMap(ds As cDataSet, target As Long, _
            Optional scheme As String = vbNullString) As cCell
    Dim dc As cCell, dmin As Double, d As Double, dr As cDataRow
    Set dc = Nothing
    For Each dr In ds.rows
        If (scheme = vbNullString Or dr.value("scheme") = scheme) Then
            d = compareColors(target, htmlHexToRgb(dr.value("hex")))
            If dc Is Nothing Or d < dmin Then
                dmin = d
                Set dc = dr.cell("hex")
            End If
        End If
    Next dr
    Set getClosestColorMap = dc
End Function
Public Sub doughnutExample()

    Dim dsout As New cDataSet
    createHotDoughnutChart _
        dsout.populateData(wholeSheet("doughnut"), , , , , , True), "heatmap", , , , , , , , , , False

    dsout.tearDown
End Sub
Public Sub doughnutPantoneExample()
    Dim dc As cCell, aYear As Variant, dsdata As cDataSet, dMap As cDataSet
    
    ' we'll use the data columns to create an array of color ramps
    ' based on the colors for each year
    Set dsdata = getDsQuick("pantonedoughnut")
    Set dMap = getcolorMap()
    
    With dsdata
        ReDim aYear(1 To .columns.count - 1)
        For Each dc In .headings
            If dc.column <> 1 Then
                aYear(dc.column - 1) = getPantoneColorsOfTheYear(dc.value, , dMap)
            End If
        Next dc
        
        ' now doughnut it - we're going to use the 2013 color ramp as outside labels.
            createHotDoughnutChart _
                dsdata, "heatmap", , 10, aYear, , , _
                getPantoneColorsOfTheYear(2013, , dMap), , , , False, vbBlack
        .tearDown
    End With
  
    dMap.tearDown
End Sub
Public Sub doughnutPantoneOne()
    Dim dc As cCell, aYear As Variant, dsdata As cDataSet
    
    ' we'll use the data columns to create an array of color ramps
    ' based on the colors for each year
    Set dsdata = getDsQuick("pantonedoughnut")
    aYear = getPantoneColorsOfTheYear(2013)
    With dsdata
        ' now doughnut it - we're going to use the 2013 color ramp as outside labels.
            createHotDoughnutChart _
                dsdata, "heatmap", , , aYear, , , _
                aYear, , , , False
        .tearDown
    End With
  
End Sub

Public Sub makePantoneWinners()
    makeRampedGeneral "swatches", getPantoneColorsOfTheYear(), _
        getPantoneColorsOfTheYear(, "name"), "Pantone colors of the year 2013 - 2000", 7
End Sub
Public Sub makePantone2013()
    makeRampedGeneral "swatches", getPantoneColorsOfTheYear(2013), _
        getPantoneColorsOfTheYear(2013, "name"), "Pantone 2013 colors", 7
End Sub
Public Sub makePantoneAllYears()
    Dim u As Collection, cc As cCell, dMap As cDataSet, nextRange As Range
    Set dMap = getcolorMap()
    
    ' do a row for winners
    Set nextRange = makeRampedGeneral("swatches", getPantoneColorsOfTheYear(, , dMap), _
        getPantoneColorsOfTheYear(, "name", dMap), "Pantone colors of the year 2013 - 2004", 7)
    
    ' the known years are here
    With pantoneYearTable()
        Set u = .column("year").uniqueValues
        For Each cc In u
            Set nextRange = makeRampedGeneral("swatches", getPantoneColorsOfTheYear(cc.value, , dMap), _
                    getPantoneColorsOfTheYear(cc.value, "name", dMap), _
                    "Pantone " & cc.toString & " colors", 7, , , nextRange)
        Next cc

        .tearDown
    End With
    dMap.tearDown
End Sub
Public Function makeRampedGeneral(sheetName As String, colorList As Variant, _
                                nameList As Variant, title As String, _
                                Optional width As Long = 7, _
                                Optional pointsPerMilestone As Long = 50, _
                                Optional fontSize As Variant = 10, _
                                Optional lastRange As Range = Nothing) As Range
                                
    Dim r As Range, i As Long, totalPoints As Long, height As Long, rNextRange As Range
    
    Application.ScreenUpdating = False
    ' going to make some color swatches
    Set r = firstCell(wholeSheet(sheetName))
    If (lastRange Is Nothing) Then
        With r.Worksheet.Cells
            .clear
        End With
    Else
        Set r = firstCell(lastCell(lastRange).Offset(1).EntireRow)
    End If
    
    ' how many columns in total
    totalPoints = arrayLength(colorList) * pointsPerMilestone
    height = width * 6
    
    Set rNextRange = r.Resize(5, totalPoints)
    With rNextRange
        .columnWidth = width / pointsPerMilestone
        .rowHeight = height
        .Font.size = fontSize
        .Interior.color = vbWhite
    End With
    
    ' small space betwen swatches
    With rNextRange
        .Offset(1).Resize(1).rowHeight = height / 20
        With .Offset(.rows.count - 2).Resize(1)
            .rowHeight = height / 20
            .Interior.color = vbBlack
        End With
        .Offset(.rows.count - 1).Resize(1).rowHeight = height / 10
        
    End With
        
    ' ramp with intermediate colors
    For i = 1 To totalPoints
        With r.Offset(, i - 1)
            .Interior.color = rampLibraryRGB(colorList, 1, totalPoints, i)
        End With
    Next i
        
    ' add a title
    With r.Resize(1, 1)
        .value = title
        .Font.color = makeColorProps(.Interior.color).textColor
    End With
        
    ' now contrast that with the non ramped
    For i = 1 To arrayLength(colorList)
        With r.Resize(1, pointsPerMilestone).Offset(2, (i - 1) * pointsPerMilestone)
            .Interior.color = colorList(i)
            With .Resize(1, 1)
                .Font.color = makeColorProps(.Interior.color).textColor
                .value = nameList(i + LBound(nameList) - 1)
            End With
        End With
    Next i
    Application.ScreenUpdating = True
    Set makeRampedGeneral = rNextRange
   
End Function
Public Sub makeRampedPantone()
    Dim r As Range, colorList As Variant, i As Long, _
         self As cDataSet, totalPoints As Long, nameList As Variant
    
    ' going to make some color swatches
    Set r = firstCell(wholeSheet("swatches"))
    r.Worksheet.Cells.clear
    r.Worksheet.Cells.Interior.color = vbWhite
    
    ' various parameters for layout
    Const width = 72
    Const height = 64
    Const pointsPerMilestone = 50
    
    ' get pantone spring collection colors
    colorList = getPantoneColorsOfTheYear(2013)
    nameList = getPantoneColorsOfTheYear(2013, "name")
    totalPoints = arrayLength(colorList) * pointsPerMilestone
    
    With r.Resize(2, totalPoints)
        .columnWidth = width / totalPoints
        .rowHeight = height
    End With
        
    ' ramp with intermediate colors
    For i = 1 To totalPoints
        With r.Offset(, i - 1)
            .Interior.color = rampLibraryRGB(colorList, 1, totalPoints, i)
        End With
    Next i
        
    ' add a title
    With r.Resize(1, 1)
        .value = "Pantone 2013 Spring Colors"
        .Font.color = makeColorProps(.Interior.color).textColor
    End With
        
    ' now contrast that with the non ramped
    For i = 1 To arrayLength(colorList)
        With r.Resize(1, pointsPerMilestone).Offset(1, (i - 1) * pointsPerMilestone)
            .Interior.color = colorList(i)
            With .Resize(1, 1)
                .Font.color = makeColorProps(.Interior.color).textColor
                .value = nameList(i + LBound(nameList) - 1)
            End With
        End With
    Next i
        
   
End Sub
Public Sub makeRampedSwatches()
    Dim r As Range, nameList As Variant, i As Long, _
        ramp As Variant, self As cDataSet, totalPoints As Long
    
    ' going to make some color swatches
    Set r = firstCell(wholeSheet("swatches"))
    r.Worksheet.Cells.clear
    r.Worksheet.Cells.Interior.color = vbWhite
    
    ' going to use some dulux names
    Const schemePrefix = "dulux-"
    Const width = 72
    Const height = 64
    Const pointsPerMilestone = 50
    
    ' get the color map table
    With getcolorMap()
        
        ' refer to the dataset for later
        Set self = .self
        
        ' these are our colors
        nameList = Array( _
            "charred chocolate", _
            "charred clay", _
            "cheater", _
            "cheesy grin", _
            "chenille" _
        )
        
        ' lets get the actual colors
        ReDim ramp(1 To arrayLength(nameList))
        For i = LBound(nameList) To UBound(nameList)
            ramp(i + 1 - LBound(nameList)) = .value(schemePrefix & nameList(i), "rgb")
        Next i

        
        totalPoints = arrayLength(nameList) * pointsPerMilestone
        With r.Resize(2, totalPoints)
            .columnWidth = width / totalPoints
            .rowHeight = height
        End With
        
        ' ramp with intermediate colors
        For i = 1 To totalPoints
            With r.Offset(, i - 1)
                .Interior.color = rampLibraryRGB(ramp, 1, totalPoints, i)
            End With
        Next i
        
        ' add a title
        With r.Resize(1, 1)
            .value = "ramped swatch"
            .Font.color = makeColorProps(.Interior.color).textColor
        End With
        
        ' now contrast that with the non ramped
        For i = 1 To arrayLength(nameList)
            With r.Resize(1, pointsPerMilestone).Offset(1, (i - 1) * pointsPerMilestone)
                .Interior.color = ramp(i)
                With .Resize(1, 1)
                    .Font.color = makeColorProps(.Interior.color).textColor
                    .value = nameList(i + LBound(nameList) - 1)
                End With
            End With
        Next i
        
        'cleanup
        .tearDown
    End With
   
End Sub

Public Sub makeSimpleSwatches()
    Dim r As Range, nameList As Variant, i As Long, self As cDataSet
    
    ' going to make some color swatches
    Set r = firstCell(wholeSheet("swatches"))
    r.Worksheet.Cells.clear

    ' going to use some dulux names
    Const schemePrefix = "dulux-"
    
    ' get the color map table
    With getcolorMap()
        ' refer to the dataset for later
        Set self = .self
        ' these are our colors
        nameList = Array( _
            "charred chocolate", _
            "charred clay", _
            "cheater", _
            "cheesy grin", _
            "chenille" _
        )
        
        ' look up the colors, get and good text colors
        For i = LBound(nameList) To UBound(nameList)
            With r.Offset(, i - LBound(nameList))
                .Interior.color = self.value(schemePrefix & nameList(i), "rgb")
                .Font.color = makeColorProps(.Interior.color).textColor
                .value = nameList(i)
            End With
        Next i

        'cleanup
        .tearDown
    End With
   
End Sub
Private Function getDsQuick(name As String) As cDataSet
    Dim ds As cDataSet
    Set ds = New cDataSet
    Set getDsQuick = ds.load(name)
End Function
Public Sub heatMapExample()
    Dim dsout As New cDataSet
    createSurfaceChart _
        dsout.populateData(wholeSheet("matrixout"), , "matrixout", True, , , True, "matrix"), _
        "heatmap"
    dsout.tearDown
End Sub
Public Sub colorRampVisualize()
    Dim dsout As New cDataSet
    createSurfaceChart _
        dsout.populateData(wholeSheet("crampviz"), , , True, , , True, "y/x"), _
        "crampChart", xlSurfaceTopView, 200, "heatmaptowhite", False
    dsout.tearDown
End Sub
Public Sub colorRampTerrain()
    Dim dsout As New cDataSet
    createSurfaceChart _
        dsout.populateData(wholeSheet("crampviz"), , , True, , , True, "y/x"), _
        "crampChart", xlSurfaceTopView, 200, "terrain", False, 1.3
    dsout.tearDown
End Sub
Public Sub pantoneYearsVisualize()
    Dim dsout As New cDataSet
    createSurfaceChart _
        dsout.populateData(wholeSheet("crampviz"), , , True, , , True, "y/x"), _
        "crampChart", xlSurfaceTopView, 400, getPantoneColorsOfTheYear(2013), False
    dsout.tearDown
End Sub
Public Function getPantoneColorsOfTheYear(Optional yearSelect As Variant = Empty, _
            Optional columnName As String = "hex", Optional colorMapSet As cDataSet = Nothing) As Variant
    Dim ds As cDataSet, dMap As cDataSet, dr As cDataRow, colors As Variant, n As Long, c As String
    Set ds = New cDataSet
    
    ' using the home and fashion pantone set
    Const colorSetPrefix = "pfh-"
    ReDim colors(1 To 1)
    If Not colorMapSet Is Nothing Then
        Set dMap = colorMapSet
    Else
        Set dMap = getcolorMap()
    End If
    ' get the colors for the list of colors of the year and return them as an array
    With pantoneYearTable()
        n = 0
        For Each dr In .rows
            If (IsEmpty(yearSelect) And .isCellTrue(dr.row, "winner")) Or _
                (dr.value("year") = yearSelect) Then
                n = n + 1
                ReDim Preserve colors(1 To n)
                c = dMap.toString(makeKey(colorSetPrefix & dr.toString("name")), columnName)
                If (columnName = "hex") Then
                    colors(n) = htmlHexToRgb(c)
                
                ElseIf columnName = "name" Then
                    colors(n) = dr.toString("name")
                
                End If
            End If
        
        Next dr
        .tearDown
    End With
    
    If colorMapSet Is Nothing Then
        dMap.tearDown
    End If

    getPantoneColorsOfTheYear = colors
End Function
Public Function pantoneYearTable() As cDataSet
    ' get the table with the pantone colors of the year
    Dim ds As cDataSet
    Set ds = New cDataSet
    Set pantoneYearTable = ds.populateData(wholeSheet("colorsoftheyear"), , , , , , True)
End Function
Public Function getcolorMap(Optional curt As Boolean = True) As cDataSet
    Dim ds As cDataSet
    Set ds = New cDataSet
    If curt Then
        ds.populateData toEmptyRow(wholeSheet("colorTable").Resize(, 3)), , , True, , , , "name"
    Else
        ds.populateData wholeSheet("colorTable"), , , True, , , True, "name"
    End If
    Set getcolorMap = ds
End Function
Public Sub colorMap()
    Dim dr As cDataRow, p As colorProps

    With getcolorMap(False)
        ' get all we know about each pantone color
        For Each dr In .rows
            With dr
                ' get all we know about this color
                p = makeColorProps(htmlHexToRgb(.toString("hex")))
                .cell("magenta").value = p.magenta
                .cell("yellow").value = p.yellow
                .cell("black").value = p.black
                .cell("cyan").value = p.cyan
                .cell("red").value = p.red
                .cell("green").value = p.green
                .cell("blue").value = p.blue
                .cell("htmlHex").value = p.htmlHex
                .cell("rgb").value = p.rgb
                .cell("textcolor").value = p.textColor
                .cell("luminance").value = p.luminance
                .cell("contrastRatio").value = p.contrastRatio
                .cell("value").value = p.value
                .cell("hue").value = p.hue
                .cell("saturation").value = p.saturation
                .cell("lightness").value = p.lightness
                .cell("x").value = p.x
                .cell("y").value = p.y
                .cell("z").value = p.z
                .cell("lstar").value = p.LStar
                .cell("astar").value = p.aStar
                .cell("bstar").value = p.bStar
                .cell("cstar").value = p.cStar
                .cell("hstar").value = p.hStar
                ' color the row with and use a friendly text color
                .where.Interior.color = p.rgb
                .where.Font.color = p.textColor
            End With
        Next dr
        .bigCommit
        .tearDown
    
    End With
    
End Sub
Public Sub colorRampElevation()
    Dim dsout As New cDataSet, ds As New cDataSet
    ' the formula data contains rand() function so it will recalculate-
    Application.Calculate
    ' copy the values elsewhere so it doesnt happen again and change the finished chart
    ds.populateData(wholeSheet("elevate"), , , , , , True).bigCommit _
            whereIsThis("straightcopy!a1"), True
    'base on the copied data
    createSurfaceChart _
        dsout.populateData(wholeSheet("straightcopy"), , "elevate", True, , , True, "lat/lon"), _
        "top", , 400, "terrainnosea", False, , False
     dsout.tearDown
     ds.tearDown
End Sub
Public Sub testheatmapscale()
    Dim dsout As cDataSet, dc As cCell, c As colorProps
    Dim mx As Variant, mn As Variant, dr As cDataRow
    Set dsout = New cDataSet
    With dsout.populateData(wholeSheet("heatmapcolors"), , , , , , True)
        mx = .max
        mn = .min
        ' do the heading as a heatmap scale
        For Each dc In .headingRow.headings
            dc.where.Interior.color = colorRamp(1, .columns.count, dc.column)
        Next dc
        'now the data
        For Each dr In .rows
            For Each dc In dr.columns
              If (Not IsEmpty(dc.value)) Then
                c = makeColorProps(rampLibraryRGB("heatmap", mn, mx, dc.value))
                dc.where.Interior.color = c.rgb
                dc.where.Font.color = c.textColor
              End If
            Next dc
        Next dr
    End With
    dsout.tearDown
   
End Sub

Public Sub testHeatMapScaleRamp()
    Dim m As Long, n As Long, r As Range, aList As Variant, _
        vList As Variant, i As Long, ds As cDataSet
        
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    
    Set r = Sheets("heatmapramp").Range("a1")
    r.Worksheet.Cells.clear
    
    ' these are the library entries we'll use
    aList = Array("pantone2013fashion", "pantone2012fashion", "pantone2011fashion", _
                "pantone2010fashion", "pantonecolorsoftheyear", _
                "heatmap", "heatmaptowhite", "blacktowhite", "whitetoblack", "hotinthemiddle", _
                    "candylime", "heatcolorblind", "gethotquick", "greensweep", "greendollar")
                    
    ' demonstrate mixture of dynamically created and library entry ramps
    vList = aList
    Set ds = getcolorMap()
    vList(LBound(vList)) = getPantoneColorsOfTheYear(2013, , ds)
    vList(LBound(vList) + 1) = getPantoneColorsOfTheYear(2012, , ds)
    vList(LBound(vList) + 2) = getPantoneColorsOfTheYear(2011, , ds)
    vList(LBound(vList) + 3) = getPantoneColorsOfTheYear(2010, , ds)
    vList(LBound(vList) + 4) = getPantoneColorsOfTheYear(, , ds)
    
    Const npoints = 200
    For i = LBound(aList) To UBound(aList)
        
        
        For m = 0 To npoints
            r.Offset(i - LBound(aList), m).Interior.color = _
                rampLibraryRGB(vList(i), 0, npoints, m)
        Next m
        
        'label and choose a decent text color
        With r.Offset(i - LBound(aList), 0)
            .value = aList(i)
            .Font.color = makeColorProps(.Interior.color).textColor
        End With
        
    Next i
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub


Private Function findInCollection(col As Collection, sVal As Variant) As Long
    Dim n As Long
    For n = 1 To col.count
        If makeKey(col(n).value) = makeKey(sVal) Then
         findInCollection = n
         Exit Function
        End If
    Next n
    findInCollection = 0
End Function
Private Function knownShape(col As Variant, sname As String) As Long
    Dim n As Long, s As shape
    n = 0
    For Each s In col
        n = n + 1
        If makeKey(s.name) = makeKey(sname) Then
            knownShape = n
            Exit Function
        End If
    Next s
    
End Function
Sub makeSkillPoleMapFilterProc(Optional useCurrent As Boolean = False)
    Dim dst As cDataSet, ds As cDataSet, colTarget As Collection, _
        dr As cDataRow, cc As cCell, n As Long, _
        a() As Long, s As shape, mn As Long, mx As Long, ck As String, cMap As New Collection, _
        sname As String, st As String

    Const colorEmpty = 7897995
    ' get data
    Set dst = New cDataSet
    dst.populateData Range("completedata"), , , , , , True, , , , True

    st = "shortTarget"
    If useCurrent Then st = "shortCurrent"
    Set colTarget = dst.column(st).uniqueValues(eSortAscending)
    ReDim a(1 To colTarget.count)
    
    For Each dr In dst.rows
        If Not dr.hidden Then
            ' here's one - is this a known shape?
            ck = makeKey(dr.value(st))
            sname = "S_" & ck
            With Sheets("world map")
                If isinCollection(.Shapes, sname) Then
                ' we'll take it
                    If (isinCollection(cMap, ck)) Then
                        n = knownShape(cMap, sname)
                    Else
                        cMap.add .Shapes(sname), ck
                        n = knownShape(cMap, sname)
                    End If
                    a(n) = a(n) + 1
                Else
                    MsgBox (sname & " map shape not found")
                End If
            End With

        End If
    Next dr

    mn = -1
    mx = -1
    ' get max/min
    For n = LBound(a) To UBound(a)
        If (a(n) > mx Or mx = -1) Then mx = a(n)
        If (a(n) < mn Or mn = -1) Then mn = a(n)
    Next n


    ' add heatmap shapes
    For n = 1 To cMap.count
        With cMap(n)
            .Fill.ForeColor.rgb = heatmapColor(mn, mx, a(n))
        End With
    Next n
End Sub
Public Function shapeRamp(ds As cDataSet, wNameWhereShapesAre As String, _
                            Optional dataColumnName As String = "data", _
                            Optional shapeColumnName As String = "shapes", _
                            Optional screenTipColumnName As String = vbNullString, _
                            Optional unknownShapeName As String = vbNullString, _
                            Optional unusedShapeColor As Long = 7897995, _
                            Optional rampName As String = "heatmap", _
                            Optional showValueAsTip As Boolean = True, _
                            Optional complain As Boolean = True, _
                            Optional unusedShapeColorApply As Boolean = False) As cDataSet
    ' this will create a colorramp for a data set on a group of shapes (usually a choropleth map)

    Dim ws As Worksheet, dr As cDataRow, workwith As Long, _
            co As Collection, n As Long, sname As String, s As shape, _
            mn As Variant, mx As Variant, u As Variant, bu As Boolean, a() As Variant, t As String
    
    ' check all args are good
    Set ws = sheetExists(wNameWhereShapesAre)
    If Not (ds.headingRow.validate(True, dataColumnName, shapeColumnName) And _
            Not ws Is Nothing) Then
        Exit Function
    End If
    If screenTipColumnName <> vbNullString Then
        If Not (ds.headingRow.validate(True, screenTipColumnName)) Then
            Exit Function
        End If
    End If
    
    If (unknownShapeName <> vbNullString And findShape(unknownShapeName, ws) Is Nothing) Then
        MsgBox ("shape " & unknownShapeName & " doesnt exist")
        Exit Function
    End If
    
    ' anything to do?
    workwith = ds.visibleRowsCount
    If workwith <= 0 Then
        MsgBox "no data visible - have you filtered too much?"
        Exit Function
    End If
    
    ' ok lets go - delete any hyperlinks (which are used for screentips)
    clearHyperLinks ws
    ' all shapes to accumulate
    Set co = ds.column(shapeColumnName).uniqueValues
    ReDim a(1 To co.count) As Variant
    
    bu = False
    For Each dr In ds.rows
        sname = dr.toString(shapeColumnName)
        n = findInCollection(co, sname)
        a(n) = a(n) + dr.value(dataColumnName)
        If (findShape(sname, ws) Is Nothing) Then
            u = u + a(n)
            bu = True
        End If
    Next dr
    ' min and max may need modified if there were some unknowns
    mx = ds.column(dataColumnName).max
    mn = ds.column(dataColumnName).min
    If bu Then
        If u > mx Then mx = u
        If u < mn Then mn = u
    End If
    ' default coloration
    If unusedShapeColorApply Then
        For Each s In ws.Shapes
            s.Fill.ForeColor.rgb = unusedShapeColor
        Next s
        If bu Then
            findShape(unknownShapeName, ws).Fill.ForeColor.rgb = unusedShapeColor
        End If
    End If
    ' now plot
    For n = LBound(a) To UBound(a)
        Set s = findShape(co(n).toString, ws)
        If (Not s Is Nothing) Then
            s.Fill.ForeColor.rgb = rampLibraryRGB(rampName, mn, mx, a(n))
            t = vbNullString
            If screenTipColumnName <> vbNullString Then
                t = ds.toString(co(n).row, screenTipColumnName)
            End If
            If showValueAsTip Or t <> vbNullString Then
                ws.Hyperlinks.add s, "", "", ScreenTip:=t & "(" & CStr(a(n)) & ")"
            End If
        Else
            If (complain) Then MsgBox ("Shape doesnt exist " & co(n).toString)
        End If
    Next n
    'unknown plot?
    If (unknownShapeName <> vbNullString And bu) Then
        Set s = findShape(unknownShapeName, ws)
        s.Fill.ForeColor.rgb = rampLibraryRGB(rampName, mn, mx, u)
        t = "Unknown shapes"
        If showValueAsTip Or t <> vbNullString Then
                ws.Hyperlinks.add s, "", "", ScreenTip:=t & "(" & CStr(u) & ")"
        End If
    End If
    Set shapeRamp = ds
End Function
Private Function makeSomeTables()
    Dim styles As String

    styles = "color,background-color,font-size"

    tableToHtml "colorTable", , , styles, "google"
    tableToHtml "colorTable", , 20, styles, "google"
    tableToHtml "colorTable", , 20, styles, "static"
    tableToHtml "inputData", , , , "static"
    tableToHtml "inputData"
    
End Function