QAT Code: The Pairs Expansion Method

From Catcliffe Development
Jump to navigation Jump to search
The 'pair' is combined data values of one measured channel, as a token, combining UNIQUE VALUES of the sampled data ('atoms' of a value category) 

PairsExport


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

Combinatorics


Public Function Combinatorics(ByVal TabularString As String) As String()
    
    '   Return a string array loaded with all the combinations of SecNames
    '   in TabularString, ignoring the first tabular string entry, which is an Atom FirstName
    Dim maxName             As Long
    Dim maxNdx              As Long
    Dim moduloNdx           As Long
    Dim strCombinations()   As String 'array
    Dim strNames()          As String 'array
    Dim ndxCombination      As Long
    Dim j, k, intLast       As Integer
    
    On Error Resume Next
    
    '   TabularString format (Paired)
    '   FirName Tab SecName1 Tab SecName2 Tab SecName3...
    
    With New clsStopWatch
        .Reset
        
        modMain.TrimTrailingCharacters TabularString, vbTab
        
        strNames = Split(TabularString, vbTab)
        'Note: the first array element is a firstName, not to be combined
        
        maxName = UBound(strNames)
        maxNdx = maxName
        
        If maxName > 1 Then '  0,1 and 2 elements -- 0= FirName; 1,2= Secnames
           
            '   Redim to something larger than typically expected
            '   Redim again later to size used after loading array
            ReDim strCombinations(maxName * maxName)
            
            'Debug.Print vbCrLf & "Combining FirName: " & strNames(0)
            
            If mbooCancel Then Exit Function
                                                         
            If maxName > 1 Then '   very key factor
                '   Key factor: if maxName is larger than two (larger than 1 for zero-based array elements)
                '               then at least a pair of mart rows matching columns A-Names
                '               are sharing a B-Name
                For k = 1 To maxName - 1    ' Start with element 1 of the zero-based strNames() array.
                    DoEvents
                                        
                    For j = 1 To (maxName - k)
                        '   Check array size and redim if more elements are needed
                        If ndxCombination > maxNdx Then
                            maxNdx = maxNdx + 1000
                            ReDim Preserve strCombinations(maxNdx)
                            'Debug.Print "maxNdx: " & maxNdx
                        End If
                        
                        '   Add the combination to the output array
                        strCombinations(ndxCombination) = strNames(k) & "**" & strNames(k + j)
                                                                        
                        'Debug.Print "(" & CStr(k) & ")-(" & CStr(k + j) & ") = " & strCombinations(ndxCombination)
                        ndxCombination = ndxCombination + 1
                        If moduloNdx Mod 5 = 0 Then
                            RaiseEvent Progress("Expanding combinatorics: " & CStr(moduloNdx))
                            DoEvents
                            If mbooCancel Then Exit Function
                        End If
                    Next
                    moduloNdx = moduloNdx + 1
                Next
                
                '   Redim the combinations array to the size used
                ReDim Preserve strCombinations(ndxCombination - 1)
                
                '   Return the array
                Combinatorics = strCombinations
                
            End If 'maxName
        Else
            'Debug.Print vbCrLf & "Skipping"
        End If
    End With 'New clsStopWatch
    
End Function

ExpandPairs

In the working-loop of pair expansion below, a collection object (mtWh.colAtomsKeychain) has the structures that relate to the mathematical expansion implemented by the QAT.
See below: QAT Code: The Pairs Expansion Method#Enumeration of Coincedence

Working loop of the ExpandPairs()

'   Create the paired-combinations of Atoms sharing Links.                
'   Enumerate atoms, creating a tabulation by string-concatenation
'   of any new combinatrics joined from the array returned by the
'   transform method producing combinatorics.

RaiseEvent Progress("Pairs combination-expansion beginning...")

ndx = 0
For Each varX In mtWh.colAtomsKeychain
    strJoin = Join(Combinatorics(varX), "**")
    If Len(strJoin) Then
        strPairs = Join(Array(strPairs, strJoin), Me.DataDelimRow) ' future: this needs checked for delay
    End If
    If ndx Mod 2 = 0 Then
        RaiseEvent Progress("Expanding - (" & CStr(ndx) & ")...")
        DoEvents
    End If
    ndx = ndx + 1
Next

RaiseEvent Console("Pairs expanded.  [" & CStr(.Elapsed) & " msec]")

The ExpandPairs() function containing the working loop above


Public Function ExpandPairs() As Boolean
    ' Create the pair-combinations of all the Atoms that DO HAVE shared conjectural-regularity.
    
    Dim ndx         As Long
    Dim strField()  As String 'array
    Dim strPairs    As String
    Dim strJoin     As String
    Dim varX        As Variant
    
    '   Pairs format (Sorted):
    '   Atom1 ** Atom2 CR Atom3 ** Atom 4 CR, ...
   
    On Error GoTo trap
    
    If mtWh.State >= enumWhStates.ExtractedKeychains Then
        Set mtWh.colPairs = New Collection
        With New clsStopWatch
            If mtWh.State >= Loaded Then
                '   Create the paired-combinations of Atoms sharing Links.
                
                '   Enumerate atoms, creating a tabulation by string-concatenation
                '   of any new combinatrics joined from the array returned by the
                '   transform method producing combinatorics.
                RaiseEvent Progress("Pairs combination-expansion beginning...")
                ndx = 0
                For Each varX In mtWh.colAtomsKeychain
                    strJoin = Join(Combinatorics(varX), "**")
                    If Len(strJoin) Then
                        strPairs = Join(Array(strPairs, strJoin), Me.DataDelimRow) ' future: this needs checked for delay
                    End If
                    If ndx Mod 2 = 0 Then
                        RaiseEvent Progress("Expanding - (" & CStr(ndx) & ")...")
                        DoEvents
                    End If
                    ndx = ndx + 1
                Next
                RaiseEvent Console("Pairs expanded.  [" & CStr(.Elapsed) & " msec]")
                
                .Reset ' timer
                
                '   Store the Pairs tabular string data as a string array.
                mtWh.Pairs = Split(strPairs, Me.DataDelimRow)
                mtWh.PairsCount = UBound(mtWh.Pairs) + 1
                
                '   Sort the new Pairs array.
                QuickSortVariants mtWh.Pairs, 1, UBound(mtWh.Pairs), 1, UBound(mtWh.Pairs)
                RaiseEvent Console(CStr(mtWh.PairsCount) & " Pairs sorted.  [" & CStr(.Elapsed) & " msec]")
                RaiseEvent Progress("")
                
                mtWh.State = enumWhStates.ExpandedPairs
                ExpandPairs = True
                RaiseEvent Console(CStr(mtWh.PairsCount) & " Pairs expanded.  [" & CStr(.Elapsed) & " msec]")
                
            End If
        End With
    Else
        RaiseEvent Console("clsWhse.ExpandPairs: Failure: The Atoms Keychain has not been extracted.")
                
    End If ' mtWh.State >= enumWhStates.ExtractedKeychains
            
    Exit Function
ExitPoint:
    RaiseEvent Progress("")
Exit Function

trap:
    RaiseEvent Console("clsWhse.ExpandPairs: " & Err.Source & " Error(" & CStr(Err.Number) & "): '" & CStr(Err.Description) & "'")
    Resume ExitPoint
    Resume
End Function