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

<pre style="margin:0 3em; font:normal 14px monospace;" 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