Раскрашивание каждой точки диаграммы на основе данных с использованием последовательных или расходящихся цветовых шкал

Полный пример на GitHub: https://github.com/DanGolding/Scatter-plot-with-color-grading-in-Excel

Если ваши данные о цвете имеют только несколько дискретных значений, самый простой способ - это отобразить их в виде различных серий , как показано здесь. Однако, если у вас есть последовательные данные, вам нужно будет использовать VBA для циклического перебора каждой точки ряда данных и изменения ее цвета.

Используя редактор макросов, довольно легко найти код для изменения цвета отдельного маркера. Затем вы можете изменить его, чтобы он вписался в цикл. Этот код будет показан позже. Теперь задача состоит в том, чтобы выбрать хорошее отображение цветов. Этот ответ предоставляет код, который создает отображение, которое представляет собой градиент от одного цвета к другому путем простой линейной модуляции отдельного RGB. каналы. Однако я считаю, что более естественным отображением последовательных данных является сохранение оттенка и насыщенности цветовой постоянной, а затем изменение канала яркости / яркости. Вот, например, как Excel изменяет стандартные цвета в палитре цветов:

К счастью, вы можете выставить функция API для преобразования цветового пространства HLS в цветовое пространство RGB, необходимое для установки цвета маркера. Для этого добавьте в верхнюю часть модуля следующую строку кода:

Public Declare PtrSafe Function ColorHLSToRGB Lib "shlwapi.dll" (ByVal wHue As Long, ByVal wLuminance As Long, ByVal wSaturation As Long) As Long

Обратите внимание, что я добавил PtrSafe в строку выше, поскольку это, похоже, заставляет функцию работать как с 32-разрядными, так и с 64-разрядными версиями Excel.

Путем некоторых экспериментов я обнаружил, что вы не можете сделать канал wLuminance выше, чем 240, поэтому я использую следующую функцию для сопоставления наших данных окраски (столбец T в вопросе) в диапазоне от 0 до 240:

Function normalize(datum As Variant, dataMin As Double, dataMax As Double) As Integer
    normalize = CInt(((datum - dataMin) / (dataMax-dataMin)) * 241)
End Function

Последний код для раскраски диаграммы:

Sub colourChartSequential()

    Dim data As Variant
    Dim dataMin As Double
    Dim dataMax As Double

    data = Range("T1:T50") 'Modify this as needed, probably to be more dynamic
    dataMin = WorksheetFunction.min(data) 'Note this doesn't work if your data are formatted as dates for some reason...
    dataMax = WorksheetFunction.max(data)

    With Worksheets("Sheet1").ChartObjects("Chart 1").Chart.FullSeriesCollection(1) 'Change "Chart 1" to the name of your chart

        Dim Count As Integer
        For Count = 1 To UBound(data)
             datum = data(Count, 1)
             .Points(Count).Format.Fill.BackColor.rgb = ColorHLSToRGB(161, normalize(datum, dataMin, dataMax), 220)
        Next Count

    End With

End Sub

Обратите внимание, что я вызвал ColorHLSToRGB(161, normalize(datum, dataMin, dataMax), 220) со значением оттенка 161 и значением насыщенности 220. Я получил эти значения из палитры цветов, начав с базового цвета, затем выбрав больше цветов, а затем изменив раскрывающийся список (выделенный красным ниже) с RGB на HSL. Также обратите внимание, что полоса справа от черного, синего и белого - это отображение цветов, которое вы получаете только при изменении яркости.

Кстати, если вы хотите адаптировать это для расходящихся данных, я предлагаю изменить функцию нормализации в диапазоне от 240 до 120 (то есть 240 для низких значений, чтобы он был белым около нуля), а затем адаптировать код к чему-то вроде этого ( обратите внимание, что коды предполагают, что данные расходятся вокруг 0, но вы всегда можете это изменить):

Function normalizeDivergent(datum As Variant, dataMin As Double, dataMax As Double) As Integer
    normalizeDivergent = 240 - CInt(((datum - dataMin) / (dataMax - dataMin)) * 121)
End Function

Sub colourChartDivergent()

    Dim data As Variant
    Dim dataMin As Double
    Dim dataMax As Double

    Dim lastRow As Integer
    lastRow = Range("T1").End(xlDown).row
    data = Range("T1:T" & lastRow)
    dataMin = WorksheetFunction.min(data)
    dataMax = WorksheetFunction.max(data)

    dataMax = WorksheetFunction.max(dataMax, -dataMin)
    dataMin = 0

    With Worksheets("Sheet1").ChartObjects("Chart 1").Chart.FullSeriesCollection(1)

        Dim Count As Integer
        For Count = 1 To UBound(data)
             datum = data(Count, 1)

            If datum > 0 Then
                .Points(Count).Format.Fill.BackColor.rgb = ColorHLSToRGB(161, normalizeDivergent(datum, dataMin, dataMax), 220)
            Else
                .Points(Count).Format.Fill.BackColor.rgb = ColorHLSToRGB(0, normalizeDivergent(-datum, dataMin, dataMax), 220)
            End If
        Next Count

    End With

End Sub

Что дает что-то вроде

РЕДАКТИРОВАТЬ:

После прочтения этой замечательной статьи: http://vis4.net/blog/posts/avoid-equidistant-hsv-colors/, которые привели меня к http://tools.medialab.sciences-po.fr/iwanthue/theory.php и https://vis4.net/blog/posts/mastering-multi-hued-color-scales/ Я понял, что интерполяция в пространстве HSL также ошибочна. Преобразование в цветовые пространства CIE L * a * b * / HCL в VBA с последующим выполнением процедуры Безье предложенные vis4.net интерполяция и коррекция яркости казались слишком сложными. Поэтому вместо этого я использовал их потрясающий инструмент для создания таблицы поиска по карте цветов: http://gka.github.io/palettes/#diverging|c0=DarkRed,LightSalmon,white|c1=белый,PaleTurquoise,MediumBlue|steps=255|bez0=1|bez1=1|coL0=1|coL1=1, который, надеюсь, более линейен по восприятию, чем мой оригинальный HSL интерполяция. Обратите внимание, что я попытался выбрать цвет так, чтобы график яркости (черные диагональные линии под цветовой полосой) был примерно симметричным, чтобы воспринимаемая яркость отображалась в абсолютном значении)

Шаг первый - скопировать первый блок шестнадцатеричных чисел и сохранить их как текстовый файл:

Затем в Excel я использовал DATA -> From Text, чтобы импортировать шестнадцатеричные числа (разделенные пробелами), транспонировал их, чтобы перейти в столбец A, очистил их, используя формулу =MID(A1,2,6), спустившись вниз по столбцу B, а затем разделил компоненты RGB на столбцы C - E используя формулы =HEX2DEC(LEFT(B1,2)) для красного канала, =HEX2DEC(MID(B1,3,2)) для синего канала и =HEX2DEC(RIGHT(B1,2)) для зеленого канала.

Затем я проверил эти значения RGB, раскрасив ячейки в столбце G, используя этот код VBA:

Sub makeColourBar()
    Dim row As Integer
    For row = 1 To 255
        Range("G" & row).Interior.color = rgb(Range("C" & row).Value, Range("D" & row).Value, Range("E" & row).Value)
    Next row
End Sub

что привело к правильному

Теперь, чтобы применить эту цветовую карту к диаграмме рассеяния x-y, я написал этот код

Function normalizeLookUp(datum As Variant, dataMin As Double, dataMax As Double, n As Integer) As Integer
    normalizeLookUp = CInt(((datum - dataMin) / (dataMax - dataMin)) * (n - 1)) + 1
End Function

Sub colourChartLookUp()

    Dim data As Variant
    Dim dataMin As Double
    Dim dataMax As Double

    Dim lastRow As Integer
    lastRow = Range("H1").End(xlDown).row
    data = Range("H1:H" & lastRow)
    dataMin = WorksheetFunction.min(data)
    dataMax = WorksheetFunction.max(data)

    dataMax = WorksheetFunction.max(dataMax, -dataMin)
    dataMin = -dataMax

    With Worksheets("Colour Map").ChartObjects("Chart 1").Chart.FullSeriesCollection(1)

        Dim Count As Integer
        Dim colourRow As Integer
        For Count = 1 To UBound(data)
             datum = data(Count, 1)
                colourRow = normalizeLookUp(datum, dataMin, dataMax, 255)
                .Points(Count).Format.Fill.BackColor.rgb = rgb(Range("C" & colourRow).Value, Range("D" & colourRow).Value, Range("E" & colourRow).Value)
        Next Count

    End With

End Sub

что приводит к

Обратной стороной является то, что ваша цветовая карта хранится на одном из ваших рабочих листов (хотя вместо этого вы можете сохранить ее как массив VBA), но в итоге вы должны получить цветовое сопоставление, которое воспринимается одинаково и, следовательно, более полезно для интерпретации данных.

Обратите внимание, что для последней части головоломки вы можете прочитать Добавление цветной полосы на диаграмму.