Skip to content

Instantly share code, notes, and snippets.

@brucemcpherson brucemcpherson/d3.vba
Last active Jul 7, 2017

Embed
What would you like to do?
Module for creating d3 charts from excel data
Option Explicit
' v1.01
Public Sub d3forceHere()
d3ForceDo
End Sub
Public Sub d3forceHereItunes()
d3ForceDo , "itunes force options", "itunes force fields"
End Sub
Public Sub d3forceHereNodesOnly()
d3ForceDo , "nodes only force options", "nodes only force fields"
End Sub
Public Sub d3forceTagsite()
d3NodeFocusDo , "tagsite force options", "tagsite force fields"
End Sub
Public Sub d3forceesim()
d3ForceDo , "esim force options", "esim force fields"
End Sub
Public Sub d3nltHere()
d3nltDo
End Sub
Public Sub d3nltDo(Optional wn As String = vbNullString)
Dim w As String
w = wn
If w = vbNullString Then
w = ActiveSheet.name
End If
mashupGeneral "d3allparameters", w, "node link tree", "force options", "force fields"
End Sub
Public Sub d3ForceDo(Optional wn As String = vbNullString, _
Optional optionName As String = "force options", Optional fieldName As String = "force fields")
Dim w As String
Dim UA As cUAMeasure
Set UA = registerUA("d3Force_" & optionName & "_" & fieldName)
w = wn
If w = vbNullString Then
w = ActiveSheet.name
End If
mashupGeneral "d3allparameters", w, "force", optionName, fieldName
UA.postAppKill.teardown
End Sub
Public Sub d3NodeFocusDo(Optional wn As String = vbNullString, _
Optional optionName As String = "force options", Optional fieldName As String = "force fields")
Dim w As String
Dim UA As cUAMeasure
Set UA = registerUA("d3NodeFocus_" & optionName & "_" & fieldName)
w = wn
If w = vbNullString Then
w = ActiveSheet.name
End If
mashupGeneral "d3allparameters", w, "nodefocus", optionName, fieldName
UA.postAppKill.teardown
End Sub
Public Sub mashupGeneral(params As String, data As String, item As String, _
optionName As String, fieldName As String)
Dim dSets As cDataSets, dr As cDataRow, nodesLink As cNodesLinks
Dim labels As Variant, groups As Variant, i As Long, count As String, _
links As Variant, names As Variant, styleColumn As String, _
linkName As String, url As String
Set dSets = New cDataSets
' get all parameters and data
With dSets.create()
With .init(wholeSheet(params), , "fields", True, fieldName)
' validate stuff
links = Split(.cell("links", "value").toString, ",")
groups = Split(.cell("groups", "value").toString, ",")
names = Split(.cell("names", "value").toString, ",")
count = .cell("count", "value").toString
styleColumn = .cell("styleColumn", "value").toString
linkName = .cell("linkName", "value").toString
labels = Split(.cell("labels", "value").toString, ",")
If arrayLength(labels) < 1 Then
labels = names
End If
url = vbNullString
If Not .cell("url", "value") Is Nothing Then url = .cell("url", "value").toString
End With
Set nodesLink = New cNodesLinks
nodesLink.init .init( _
wholeSheet(params), , "options", True, optionName)
.init wholeSheet(params), , item, True, item
' run through data
With .init(wholeSheet(data), , "data", , , True)
' check everything exists
Debug.Assert dsValidateHeadings(.headingRow, links)
Debug.Assert dsValidateHeadings(.headingRow, groups)
Debug.Assert dsValidateHeadings(.headingRow, labels)
Debug.Assert dsValidateHeadings(.headingRow, names)
If count <> vbNullString Then Debug.Assert _
.headingRow.validate(True, count)
If styleColumn <> vbNullString Then Debug.Assert _
.headingRow.validate(True, styleColumn)
If linkName <> vbNullString Then Debug.Assert _
.headingRow.validate(True, linkName)
For Each dr In .rows
' add the nodes
For i = LBound(links) To UBound(links)
nodesLink.addNode _
fixup(dr, links(i)), _
fixup(dr, groups(i)), _
fixup(dr, labels(i)), _
fixup(dr, count), _
fixup(dr, url), _
fixup(dr, names(i))
Next i
' make the links
For i = LBound(links) To UBound(links) - 1
nodesLink.addLink _
dr.cell(links(i)).toString, _
dr.cell(links(i + 1)).toString, _
fixup(dr, count), _
fixup(dr, styleColumn), _
fixup(dr, linkName)
Next i
Next dr
End With
End With
' generate a d3.js force chart
mashD3Force dSets.dataSet(item), nodesLink.jObject, dSets.dataSet("fields")
End Sub
Private Function fixup(dr As cDataRow, s As Variant) As Variant
fixup = Empty
If (s <> vbNullString) Then
If Not dr.cell(s, False) Is Nothing Then
fixup = dr.cell(s).value
End If
End If
End Function
Public Function dsValidateHeadings(hr As cHeadingRow, a As Variant) As Boolean
Dim i As Long
dsValidateHeadings = arrayLength(a) > 0
For i = LBound(a) To UBound(a)
If Not hr.validate(True, CStr(a(i))) Then
dsValidateHeadings = False
End If
Next i
End Function
Public Sub mashD3Force(dsParam As cDataSet, job As cJobject, _
Optional dsFields As cDataSet = Nothing)
Dim js As String, content As String
' generate a d3.js force chart from nodes.links jobject
js = job.serialize
' construct the executable file and call the browser
content = ""
With dsParam
content = content & _
.cell("titles", "value").toString
content = content & _
.cell("styles", "value").toString
If Not dsFields Is Nothing Then
With dsFields.cell("linkStyles", "value")
If .toString <> vbNullString Then
content = content & "<style>" & _
.toString & _
"</style>"
End If
End With
End If
content = content & _
.cell("code", "value").toString
content = content & _
"<script> window['mcpherTreeData'] = " & js & ";" & vbCrLf & _
"</script></head><body><div>"
content = content & _
.cell("banner", "value").toString
If Not dsFields Is Nothing Then
With dsFields.cell("banner", "value")
If .toString <> vbNullString Then
content = content & .toString
End If
End With
End If
content = content & _
.cell("body", "value").toString
With .cell("htmlname", "value")
openNewHtml .toString, content
If Not OpenUrl(.toString) Then
MsgBox ("could not open " & .toString & " using default browser")
End If
End With
End With
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.