QAT Code: The Pairs Expansion Method and Template:HeaderQATcode: Difference between pages

From Catcliffe Development
(Difference between pages)
Jump to navigation Jump to search
 
No edit summary
 
Line 1: Line 1:
{{headerQuasiAI|subcat=quasiAI}}
<div style="background:#555; border:1px outset azure; padding:0 1em; width:auto; font-name: arial; ">
{{headerQATcode|&mdash;Category Pairs Expansion }}
{{editTemplate|HeaderQATcode}}
__TOC__
<font style="font-name: arial; color:skyblue;  font-size:1.7em;">
 
The QAT Code {{{1}}}
<b><big>The 'pair' is combined data values as a token, combined from two channels of time-synchronized data measurements</big></b>
</font>
 
----
 
<font style="font-name: arial; color:skyblue; font-size:1.3em;">
== PairsExport ==
[[ QAT Code: The Pairs Expansion Method   | Pairs Expansion     ]] <small><small><sub>if</sub></small></small>
<pre style="background:#202; color:lime; border:3px outset black; padding:0 1em; width:auto; overflow:scroll; height:500px; margin:0 3em; font:normal 14px monospace;">
[[ QAT Code: The Visual Scatter Method    | Visual Scatter      ]] <small><small><sub>next</sub></small></small>
 
[[ QAT Code: The Visual Gather Method     | Visual Gather       ]] <small><small><sub>for</sub></small></small>
Public Function PairsExport() As Boolean
[[ QAT Code: Bracketing Methods          | Bracketing Clusters ]] <small><small><sub>wend</sub></small></small>
    Dim oFile      As clsFile
[[ QAT Code: Browsing Event Chemistry     | Event Chemistry      ]] <small><small><sub>wend</sub></small></small>
    Dim ndx        As Long
</font>
    Dim strField()  As String 'array
</div>
    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
 
</pre>
 
== Combinatorics ==
<pre style="background:#202; color:lime; border:3px outset black; padding:0 1em; width:auto; overflow:scroll; height:500px; margin:0 3em; font:normal 14px monospace;">
 
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
 
</pre>
 
== ExpandPairs ==
 
=== Working loop of the combinatorial expantion ===
<pre style="background:#202; color:lime; border:3px outset black; padding:0 1em; width:auto; overflow:scroll; height:500px; margin:0 3em; font:normal 14px monospace;">
'  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]")
</pre>              
 
 
=== The ExpandPairs() function containing the working loop above ===
<pre style="background:#202; color:lime; border:3px outset black; padding:0 1em; width:auto; overflow:scroll; height:500px; margin:0 3em; font:normal 14px monospace;">
 
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
 
</pre>

Revision as of 11:09, 14 July 2023

The QAT Code {{{1}}}

Pairs Expansion if Visual Scatter next Visual Gather for Bracketing Clusters wend Event Chemistry wend

Retrieved from "http://groupkos.com/dev/index.php?title=QAT_Code:_The_Pairs_Expansion_Method&oldid=637"