QAT Code: The Pairs Expansion Method
Jump to navigation
Jump to search
quasiArtifactualIntelligence —a perception from the edge
About ∞ White paper ∞ QuasiMatrix Code ∞ QAT Code ∞ Data Examples ∞ Scatter-Gather Explained ∞ The Plow Share ∞
The QAT Code —Category Pairs Expansion
The Warehouse if Pairs Expansion then Visual Scatter else Visual Cluster redim Bracketing Clusters while Event Chemistry wend SLIP class redim
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