QAT Code: Whse Class
Jump to navigation
Jump to search
About ∞ White paper ∞ QuasiMatrix Code ∞ QAT Code ∞ Data Examples ∞ Scatter-Gather Explained ∞ The Plow Share ∞
The QAT Code —Warehouse Class Code
The Warehouse if Pairs Expansion then Visual Scatter else Visual Cluster redim Bracketing Clusters while Event Chemistry wend SLIP class redim
A VB6 class wrapper around the QAT Warehouse methods
Option Explicit ' Forces variable declaration in the compile.
' Publicly visible 'Events' raised to callback-functions from within this class.
Public Event CommandResponse(ByVal Message As String) ' In-class functions communicate functional-process outcome to interface-code for interface-updates.
Public Event DataLoaded(ByRef oFile As clsFile) ' This class instance will call the 'DataLoaded' form module 'event code'.
Public Event ConjectureChanged(ByVal ConjColumnAtom As Long, ByVal ConjColumnLink As Long)
Public Event AtomsExtracted()
Public Event MartPulled()
Public Event PairsExported()
Public Event WarehouseUnloaded()
Public Event Progress(ByRef msg As String)
' Properties
Private mstrDataFile As String
Private mlngDataRowCount As Long
Private mlngDataHeaderRowIndex As Long ' An index pointing within a zero-based array to a data row with column-header captions.
Private mstrDataRowDelimiter As String
Private mstrDataColumnDelimiter As String
Private mlngConjAtomColumn As Long
Private mlngConjLinkColumn As Long
Private mbooCancel As Boolean ' Checked in long iterations: Combinatoric generation per Atom-Link conjecture match.
' Class state (code in this class that toggles these state variables also raise an 'event').
Private mbooDataLoaded As Boolean
Private mbooConjValid As Boolean
Private mbooMartPulled As Boolean
Private mbooAtomsExtracted As Boolean
Private mbooLinksExtracted As Boolean
Private mbooPairsExported As Boolean
' Class data arrays
Private mstrDataArray() As String ' array of data rows
Private mstrDataHeaderRow() As String ' array of data header-row fields (1st row from file)
Private mstrMartArray() As String ' array column data selected by Conjecture options
' Processed data arrays
Private mstrPairsArray() As String ' Atom pairs of ColA sharing Links
Private mstrLinksArray() As String ' Links of ColB per Atom
Private mcolAtoms() As String ' Hash array of VB String values as a Microsoft VB 6 keyed-collection object.
Private Sub Class_Initialize()
On Error Resume Next
End Sub
Private Sub Class_Terminate()
On Error Resume Next
End Sub
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
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
Public Function EnumeratedColumnNames(HeaderArray As Variant) As String
Dim ndx, maxNdx As Integer
Dim duplicateArray() As String 'array
'todo: work this out better
If Not IsArray(HeaderArray) Then Exit Function
maxNdx = UBound(HeaderArray)
ReDim duplicateArray(maxNdx)
For ndx = 0 To maxNdx
duplicateArray(ndx) = CStr(ndx) & vbTab & HeaderArray(ndx)
Next
' Return a string transform of array
' elements delimited by CRLF
EnumeratedColumnNames = Join(duplicateArray, vbCrLf)
End Function
Public Sub QuickSortVariants( _
vArray As Variant, _
inLow As Long, _
inHi As Long, _
ByRef ndx As Long, _
ByRef maxNdx As Long)
Dim pivot As Variant
Dim tmpSwap As Variant
Dim tmpLow As Long
Dim tmpHi As Long
tmpLow = inLow
tmpHi = inHi
' Increment completion counter
ndx = ndx + 1
pivot = vArray((inLow + inHi) \ 2)
Me.Cancel = False
While (tmpLow <= tmpHi) And Not Me.Cancel
While (vArray(tmpLow) < pivot And tmpLow < inHi)
tmpLow = tmpLow + 1
Wend
While (pivot < vArray(tmpHi) And tmpHi > inLow)
tmpHi = tmpHi - 1
Wend
If (tmpLow <= tmpHi) Then
tmpSwap = vArray(tmpLow)
vArray(tmpLow) = vArray(tmpHi)
vArray(tmpHi) = tmpSwap
tmpLow = tmpLow + 1
tmpHi = tmpHi - 1
If ndx Mod 100 = 0 Then
RaiseEvent Progress("Sort percentage remaining: " & CStr(CInt((1 - (ndx / maxNdx)) * 10000) / 100))
DoEvents
End If
End If
Wend
If (inLow < tmpHi) Then QuickSortVariants vArray, inLow, tmpHi, ndx, maxNdx
If (tmpLow < inHi) Then QuickSortVariants vArray, tmpLow, inHi, ndx, maxNdx
End Sub
Public Property Get LinkCount() As Long
On Error Resume Next
LinkCount = UBound(mstrLinksArray)
End Property
Public Function ConjectureCreate( _
ByVal AtomColumn As Long, _
ByVal LinkColumn As Long _
) As Boolean
' Return True if columns are in range, and not equal.
' Quietly persist columns set to the INI file.
Dim MaxColumn As Integer
Dim x() As String
On Error Resume Next
If Not Me.DataLoaded Then
RaiseEvent CommandResponse("Conjecture column cannot be set until the Data is loaded.")
Else
MaxColumn = UBound(Split(mstrDataArray(0), vbTab)) ' Zero-based array split on the first row in the whse data.
' Validate input (false case)
Select Case False
Case (AtomColumn >= 0)
Case (AtomColumn <= MaxColumn)
Case (LinkColumn >= 0)
Case (LinkColumn <= MaxColumn)
Case (LinkColumn <> AtomColumn)
Case Else
' Proceed with validated inputs.
' Store the column indexes.
mbooConjValid = True
mlngConjAtomColumn = AtomColumn
mlngConjLinkColumn = LinkColumn
' Save the conjecture columns.
INIWrite "Preferences", "ConjAtomColumnIndex", mlngConjAtomColumn
INIWrite "Preferences", "ConjLinkColumnIndex", mlngConjLinkColumn
End Select
End If 'me.DataLoaded
End Function
Public Function TrimTrailingCharacters(ByRef Source As String, ByVal Characters As String) As String
' Remove trailing characters passed by argument
Do While StrComp(Right$(Source, Len(Characters)), Characters) = 0
Source = Left$(Source, Len(Source) - Len(Characters))
Loop
TrimTrailingCharacters = Source
End Function
Public Function DataLoad(ByRef TabularString As String) As Boolean
On Error GoTo Trap
' String passed by reference, avoiding memory copy. The calling function destroys passed String.
' Remove any trailing row-delimiters while looping.
Do While StrComp(Right$(TabularString, 2), vbCrLf) = 0
' Remove trailing row delimiters.
TabularString = Left$(TabularString, Len(TabularString) - 2)
Loop
' Split the input String into the Data row-array at the row delimiters.
mstrDataArray = Split(TabularString, DataRowDelimiter)
mlngDataRowCount = UBound(mstrDataArray) ' Zero-based array index of the last data row read.
mbooDataLoaded = CBool(UBound(mstrDataArray) > 0) ' Loaded only if more than header record exists.
' Return outcome.
DataLoad = mbooDataLoaded
Exit Function
Trap:
Select Case Err.number
Case Else
MsgBox "DataLoad() Failure: " & formatErrorMsg(Err.number, Err.description, Err.Source), vbExclamation + vbOKOnly, "I/O error"
End Select
End Function
Public Property Get ConjAtomColumnIndex() As Long
ConjAtomColumnIndex = mlngConjAtomColumn
End Property
Public Property Let ConjAtomColumnIndex(ByVal Value As Long)
mlngConjAtomColumn = Value
End Property
Public Property Get ConjLinkColumnIndex() As Long
ConjLinkColumnIndex = mlngConjLinkColumn
End Property
Public Property Let ConjLinkColumnIndex(ByVal Value As Long)
mlngConjLinkColumn = Value
End Property
Public Property Get ConjValid() As Boolean
ConjValid = mbooConjValid
End Property
Public Property Get DataRowCount() As Long
On Error Resume Next
If mbooDataLoaded Then DataRowCount = UBound(mstrDataArray) - mlngDataHeaderRowIndex + 1 ' Zero-based data array.
End Property
Public Function FieldValue(ByVal Row As Long, ByVal Column As Long) As String
On Error Resume Next
FieldValue = Split(mstrDataArray(Row), DataColumnDelimiter)(Column)
End Function
Public Property Let DataColumnDelimiter(ByVal Value As String)
mstrDataColumnDelimiter = Value
End Property
Public Property Get DataColumnDelimiter() As String
DataColumnDelimiter = mstrDataColumnDelimiter
End Property
Public Property Let DataRowDelimiter(ByVal Value As String)
mstrDataRowDelimiter = Value
End Property
Public Property Get DataRowDelimiter() As String
DataRowDelimiter = mstrDataRowDelimiter
End Property
Public Function LoadWarehouse(Optional ByVal FileName As String) As Long
On Error GoTo Trap
' FileName must be a useable filespec (path and filename).
' Return the Data row count on success.
If Len(FileName) > 0 Then
mstrDataFile = FileName ' Save FileName passed.
With New clsFile
If .FileExists(FileName) Then
If DataLoad(.ReadAll(mstrDataFile)) Then
LoadWarehouse = Me.DataRowCount 'at least 1 more row than header row qualifies as loaded
RaiseEvent DataLoaded(.Self)
Else
RaiseEvent CommandResponse("Unable to load Warehouse data from " & mstrDataFile)
End If
Else
MsgBox "Warehouse Data File Not Found: " & .Filespec, vbInformation
RaiseEvent CommandResponse("File not found: " & .Filespec)
End If
End With
End If
Exit Function
Trap:
Select Case Err.number
Case Else
MsgBox "LoadWarehouse: " & formatErrorMsg(Err.number, Err.description, Err.Source)
Exit Function
Resume ' debugging
End Select
End Function
Public Property Get MaxColumn() As Integer
On Error Resume Next
If mbooDataLoaded Then
MaxColumn = UBound(Split(mstrDataArray(0), vbTab))
End If
End Property
Public Property Let Cancel(ByVal Value As Boolean)
mbooCancel = Value
End Property
Public Property Get Cancel() As Boolean
Cancel = mbooCancel
End Property
Public Function Clear() As Boolean
On Error Resume Next
ReDim mstrDataArray(0)
ReDim mstrDataHeaderRow(0)
ReDim mstrMartArray(0)
ReDim mstrPairsArray(0)
ReDim mstrLinksArray(0)
Clear = CBool(Err.number)
End Function
Public Property Get MartCount() As Long
On Error Resume Next
If mbooMartPulled Then MartCount = UBound(mstrMartArray) + 1
End Property
' Enumerate all Warehouse records, pulling the
' combined conjecture columns into the Mart array.
Public Function MartPull() As Boolean
Dim ndx As Long
Dim maxNdx As Long
Dim strField() As String 'array
Dim msg As String
On Error Resume Next
' Store the max array index for enumeration
maxNdx = UBound(mstrDataArray)
' Size the Mart array to the warehouse size
ReDim mstrMartArray(maxNdx)
' Check for contextual validity
If (mlngConjAtomColumn > -1) And (mlngConjLinkColumn > -1) Then
' Enumerate all Warehouse records, pulling the
' combined conjecture columns into the Mart array.
For ndx = 0 To maxNdx 'including header at 0
' Split the record into strField array at the inner delimiter
strField = Split(mstrDataArray(ndx), DataColumnDelimiter)
' Copy into the Mart array the two fields specified by conjecture
mstrMartArray(ndx) = strField(mlngConjLinkColumn) & _
DataColumnDelimiter & _
strField(mlngConjAtomColumn) ' B <Tab> A
Next ndx
' Sort the new Mart array, now in natural order from Whse
QuickSortVariants mstrMartArray, 1, UBound(mstrMartArray), 0, UBound(mstrMartArray)
' Join all array elements into a string with line delimiters streaming to file
With New clsFile
.Filespec = DataFolder & "\Mart.txt"
' Save the Mart in the data path as a
' Column/Line delimited tabulation of string data.
If .Save(Join(SourceArray:=mstrMartArray, delimiter:=mstrDataRowDelimiter)) Then
mbooMartPulled = True
MartPull = True
RaiseEvent CommandResponse("Mart columns pulled, and saved to file")
RaiseEvent MartPulled
Else
msg = "Unable to save the Mart data to file " & .Filespec
End If
End With
Else
RaiseEvent CommandResponse("Mart cannot be Pulled until both conjectures are selected, i.e., A = 4 <CR> B = 5 <CR>")
End If
End Function
Public Property Get MartPulled() As Long
MartPulled = mbooMartPulled
End Property
Public Function DataRowArray(ByVal Index As Long) As String()
On Error Resume Next
DataRowArray = Split(mstrDataArray(Index), DataColumnDelimiter)
End Function
Public Property Get DataColumnHeaders() As String()
On Error Resume Next
If mbooDataLoaded Then DataColumnHeaders = Split(mstrDataArray(0), mstrDataColumnDelimiter)
End Property
Public Property Get PairsCount() As Long
On Error Resume Next
If mbooPairsExported Then PairsCount = UBound(mstrPairsArray) + 1 'element zero contians column headers
End Property
Public Property Get PairsExported() As Long
PairsExported = mbooPairsExported
End Property
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
Public Sub MergeSecNameByFirName( _
ByVal col As Collection, _
ByVal FirName As String, _
ByVal SecName As String _
)
' Note! July 2023, twenty three years later...
' The first parameter 'ByVal' is ignored and the 'col' collection
' is passed by reference. This never threw an error.
' The line should read:
' "ByRef col As Collection, _"
'
' Build a unique collection of Firname record delimitations
' Append uniquely the secname into the Tab-delimited
' string value referenced by the collection member, keyed by Firname
' The collection members delimited format is follows:
' FirName Tab SecName1 Tab SecName2 Tab SecName3 ...
Dim strElements As String
On Error Resume Next
'Add a new member keyed by FirName...
col.Add FirName & vbTab & SecName, Key:=FirName
'This errors if member already exists -used because VB Collection object has no 'exists' function.
If Err.number = 457 Then
' Exists already, so concatentate SecName to existing SecNames if not already there
strElements = col.Item(CStr(FirName))
' Append uniquely the secname to the secname delimitation
If InStr(1, strElements, SecName) = 0 Then
'secname is not already in strSecNames, so concatenate it
strElements = Join(Array(strElements, SecName), vbTab)
col.Remove FirName
col.Add strElements, FirName
End If
End If
End Sub
Public Property Get AtomsExtracted() As Boolean
AtomsExtracted = mbooAtomsExtracted
End Property
Public Property Get DataFile() As String
DataFile = mstrDataFile
End Property
Public Property Let DataFile(ByVal Value As String)
mstrDataFile = Value
End Property
Public Property Get DataFolder() As String ' r/o
DataFolder = FileFolder(mstrDataFile)
End Property
Public Property Get DataLoaded() As Boolean
DataLoaded = mbooDataLoaded
End Property
Public Property Get DataHeaderRowIndex() As Long
DataHeaderRowIndex = mlngDataHeaderRowIndex
End Property
Public Property Let DataHeaderRowIndex(ByVal Value As Long)
mlngDataHeaderRowIndex = Value
End Property