Module for creating d3 charts from excel data

d3.vba

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