Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
heatmap donut
Public Function createHotDoughnutChart(ds As cDataSet, n As String, _
Optional xlt As Long = xlDoughnut, _
Optional granularity As Long = 300, _
Optional colorRampName As String = "heatmap", _
Optional brighten As Double = 1, _
Optional createLabelRing As Boolean = True, _
Optional labelRingColorRamp As String = "lightblue", _
Optional explosion As Long = 10, _
Optional holeSize As Long = 20, _
Optional dataValues As Boolean = False) As Chart
Dim cht As Chart, s As Series, dr As cDataRow, dc As cCell
Dim i As Long, m As Long, co As cDataColumn
Dim aSlices As Variant, mn As Variant, labelSeries As Variant
Dim mx As Variant, j As Long, o As Variant
Dim aColors As Variant, props As colorProps, k As Long, lab As String
' clean up previous attempt
deleteChart (n)
'add the chart
' the doughnut slices in this case will be equally sized
' the heatmap will show the values and fade between mid points
ReDim aSlices(1 To ds.rows.count * granularity)
ReDim aColors(1 To ds.rows.count + 2, 2 To ds.columns.count)
ReDim labelSeries(1 To ds.rows.count)
' this will determine the min/max values to ramp
mn = Application.WorksheetFunction.min(ds.where.Offset(, 1).Resize(, ds.columns.count - 1))
mx = Application.WorksheetFunction.max(ds.where.Offset(, 1).Resize(, ds.columns.count - 1))
' set all values to same for each category, since we want equal sized slices
For i = LBound(aSlices) To UBound(aSlices)
aSlices(i) = 1
Next i
' we'll use these as an extra ring for labels
If createLabelRing Then
For i = LBound(labelSeries) To UBound(labelSeries)
labelSeries(i) = 1
Next i
End If
' and the target colors based on the values
For j = LBound(aColors, 2) To UBound(aColors, 2)
For i = 1 To ds.rows.count
aColors(i + 1, j) = rampLibraryRGB(colorRampName, mn, mx, ds.value(i, j), brighten)
Next i
' for cycling - add the last color at beginning and first color at end
aColors(1, j) = aColors(1 + ds.rows.count, j)
aColors(2 + ds.rows.count, j) = aColors(2, j)
Next j
' create the chart
Set cht = Charts.add
With cht
.ChartType = xlt
.name = n
' delete any series added by default
For i = .SeriesCollection.count To 1 Step -1
.SeriesCollection(i).Delete
Next i
' add the seriess
For i = ds.columns.count To 2 Step -1
Set co = ds.columns(i)
With .SeriesCollection.NewSeries
.name = ds.headings(co.column).value
.values = aSlices
End With
Next i
' add a label series ring
If createLabelRing Then
With .SeriesCollection.NewSeries
.name = ds.headings(1).value
.values = labelSeries
End With
End If
.HasLegend = False
' fiddle with the series colors
For k = ds.columns.count To 2 Step -1
Set co = ds.columns(k)
With .SeriesCollection(ds.headings(co.column).value)
.HasDataLabels = True
For i = 1 To ds.rows.count
For j = 0 To granularity - 1
' dealing with this point
o = (i - 1) * granularity + j + 1
' note we are already half a granularity along with 1st point
props = makeColorProps(colorRamp _
(1, (granularity * (ds.rows.count + 1)), o + granularity / 2, _
extractArrayItem(aColors, k)))
With .Points(o)
.Interior.Color = props.rgb
lab = ""
' do we need a data label?
If dataValues Then
If j = 0 Then
lab = ds.value(i, co.column)
End If
End If
' label first one of these with series name
If j = 0 And i = 1 Then
If lab <> "" Then
lab = ds.headings(co.column).value & vbCr & lab
Else
lab = ds.headings(co.column).value
End If
End If
' put label or blank it
If lab <> "" Then .DataLabel.Font.Color = props.textColor
.DataLabel.Text = lab
End With
Next j
Next i
End With
Next k
' fiddle with the labels
If createLabelRing Then
With .SeriesCollection(ds.headings(1).value)
.HasDataLabels = True
.explosion = explosion
For Each dr In ds.rows
With .Points(dr.row)
props = makeColorProps(rampLibraryRGB _
(labelRingColorRamp, 1, ds.rows.count, dr.row, brighten))
.Interior.Color = props.rgb
.DataLabel.Font.Color = props.textColor
.DataLabel.Text = dr.columns(1).value
End With
Next dr
End With
End If
' fiddle with holesize
.ChartGroups(1).DoughnutHoleSize = holeSize
End With
Set createHotDoughnutChart = cht
End Function
Public Sub doughnutExample()
Dim dsout As New cDataSet
createHotDoughnutChart _
dsout.populateData(wholeSheet("doughnut"), , , , , , True), "heatmap"
dsout.tearDown
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.