QAT Code: The ExportPairs Method

quasiArtifactualIntelligence —a perception from the edge

---

edit

  About ∞ White paper ∞ QuasiMatrix Code ∞ QAT Code ∞ Data Examples ∞ Scatter-Gather Explained ∞ The Plow Share ∞

edit

The QAT Code —Warehouse.PairsExport

---

The Warehouse if Pairs Expansion then Visual Scatter else Visual Cluster redim Bracketing Clusters while Event Chemistry wend SLIP class redim

Public Function PairsExport() As Boolean
    Dim oFile       As clsFile
    Dim ndx         As Long
    Dim strField()  As String 'array
    Dim colAtoms    As Collection
    Dim colLinks    As Collection
    Dim strPaired   As String
    Dim strJoin     As String
    Dim varX        As Variant
    
    '   Atom format (Paired)
    '   FirName Tab SecName1 Tab SecName2 Tab ... SecNameX
   
    On Error GoTo Trap
    
    mbooCancel = False
    
    Set colAtoms = New Collection
    Set colLinks = New Collection
        
    With New clsStopWatch
        If mbooMartPulled Then
            .Reset '   Start timer
            RaiseEvent Progress("Pairs Export beginning...")
            '   Enumerate through all Mart array row elements
            '   and construct the Atoms.
            For ndx = 1 To Me.MartCount - 1
                DoEvents 'allowing update of cancellation flag during loop
                If Not mbooCancel Then
                    '   Split the outer Mart-array row element into an inner field-array
                    strField() = Split(mstrMartArray(ndx), vbTab)
                                        
                    '   Add a new firName to colAtoms
                    MergeSecNameByFirName colAtoms, strField(0), strField(1)
                    
                    If ndx Mod 100 = 0 Then
                        RaiseEvent Progress("Assembling atoms: record " & CStr(ndx))
                    End If
                Else
                    Exit Function
                End If 'Not mbooCancelPairs
            Next
            
            '   Enumerate through all Mart array row elements
            '   and construct the Links.
            For ndx = 1 To Me.MartCount - 1
                DoEvents 'allowing update of cancellation flag during loop
                If Not mbooCancel Then
                    '   Split the outer Mart-array row element into an inner field-array
                    strField() = Split(mstrMartArray(ndx), vbTab)
                     
                    '   Add a new SecName to colLinks (notice the parameters are switched)
                    MergeSecNameByFirName colLinks, strField(1), strField(0)  '   sort when complete

                    If ndx Mod 100 = 0 Then RaiseEvent Progress("Assembling links: record " & CStr(ndx) & "+")
                Else
                    Exit Function
                End If 'Not mbooCancelPairs
            Next
            
            '   Output the Links as tabular data
            ndx = 0
            ReDim mstrLinksArray(colLinks.Count - 1)
            
            '   Copy the collection object
            '   into the module links array
            ndx = 0
            For Each varX In colLinks
                mstrLinksArray(ndx) = varX
                ndx = ndx + 1
            Next
            
            '   Sort the new Links array, purely for human-readability, as order is irrelavant.
            QuickSortVariants mstrLinksArray, 0, UBound(mstrLinksArray), 0, UBound(mstrLinksArray)
            
            '   Store the array as a CR delimited
            '   tabular file named Links.txt
            With New clsFile
                .Save Join(mstrLinksArray, vbCrLf), DataFolder & "\Links.txt"
            End With
            RaiseEvent CommandResponse(CStr(ndx) & " Link saved as tabular data to file " & DataFolder & "\Links.txt")
            
            '   Create the paired combinatorics
            
            '   Enumerate atomics, creating a tabulation
            '   by string-concatenation of any new combinatrics
            '   joined from the array returned by the
            '   transform method producing combinatorics.
            ndx = 0
            For Each varX In colAtoms
                strJoin = Join(Combinatorics(varX), vbCrLf)
                If Len(strJoin) Then
                    If Len(strPaired) = 0 Then
                        strPaired = strJoin
                    Else
                        strPaired = strPaired & vbCrLf & strJoin
                    End If
                End If

                If ndx Mod 10 = 0 Then RaiseEvent Progress("Combining atom " & CStr(ndx) & "...")
                ndx = ndx + 1
            Next
            
            '   Store the Pairs tabular string data as a string array
            mstrPairsArray = Split(strPaired, vbCrLf)
            
            '   Sort the new Pairs array
            QuickSortVariants mstrPairsArray, 0, UBound(mstrPairsArray), 0, UBound(mstrPairsArray)
            RaiseEvent CommandResponse("Pairs sorted")
            
            '   Transform the array, now sorted
            '    to a string for storage to file
            strPaired = Join(mstrPairsArray, vbCrLf)
            
            '   Save the Pairs array to file
            Set oFile = New clsFile
            oFile.Filespec = DataFolder & "\Paired.txt"
            If oFile.Save(Join(mstrPairsArray, vbCrLf)) Then
                
                mbooPairsExported = True
                PairsExport = mbooPairsExported
                RaiseEvent CommandResponse("Pairs saved as " & DataFolder & "\Paired.txt")
                
                RaiseEvent CommandResponse("Combinatoric-pairs Export complete (Process time: " & CStr(.Elapsed / 1000) & ")")
            
            End If
        Else 'mbooMartPulled
            RaiseEvent CommandResponse("Unable to Export combinatoric-pairs because the Mart Columns have not been pulled")
        End If 'mbooMartPulled
    End With 'New clsStopWatch
    
    Exit Function
ExitPoint:
    Set colAtoms = Nothing
    Set colLinks = Nothing
Exit Function

Trap:
    RaiseEvent CommandResponse("Error in clsWhse.PairsExport: " & Err.description)
    Resume ExitPoint
    Resume
End Function