Template:HeaderQATcode and QAT Code: Whse Class: Difference between pages
XenoEngineer (talk | contribs) No edit summary |
XenoEngineer (talk | contribs) (Created page with "{{headerQuasiAI|subcat=QAT.code}} {{headerQATcode| —Warehouse Class Code}} Category:QAT.clsWhse <div style="background:azure; border:1px outset azure; margin:1em 2em; padding:0 1em; width:888px;"> 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...") |
||
Line 1: | Line 1: | ||
<div style="background: | {{headerQuasiAI|subcat=QAT.code}} | ||
{{headerQATcode| —Warehouse Class Code}} | |||
[[Category:QAT.clsWhse]] | |||
---- | |||
<div style="background:azure; border:1px outset azure; margin:1em 2em; padding:0 1em; width:888px;"> | |||
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 iFnData_ExtractAtoms(Optional ByVal TopicName As String = "A1") As Boolean | |||
' Dim ndx As Long | |||
' Dim lngCount As Long | |||
' Dim strSplitPairs() As String 'array | |||
' | |||
' Dim lngLength As Long | |||
' Dim strAtom As String | |||
' Dim strPairs As String | |||
' Dim intExtractions As Integer | |||
' | |||
' On Error Resume Next | |||
' | |||
' Screen.MousePointer = vbHourglass | |||
' | |||
' RaiseEvent CommandResponse("Extracting unique members from Paired.txt...") | |||
' | |||
' | |||
' ' Flatten the inner and outer delimiters to the same (Replace "**" with CRLF ) | |||
' strPairs = Replace(strPairs, "**", vbCrLf) | |||
' | |||
' ' Split the delimited members to an array | |||
' strSplitPairs = Split(strPairs, vbCrLf) | |||
' | |||
' ' Loop through array, checking for new Members from Pairs | |||
' lngCount = UBound(strSplitPairs) | |||
' For ndx = 0 To lngCount | |||
' ' Test that the array element is in the Atoms buffer | |||
'' If InStr(1, mstrAtomsStringBuffer, strSplitPairs(ndx)) = 0 Then 'not there | |||
'' ' Concatenate the new randomized atom to the buffer at the beginning | |||
'' mstrAtomsStringBuffer = strSplitPairs(ndx) & vbTab & CStr(Int(Rnd * 360) + 1) & vbCrLf & mstrAtomsStringBuffer | |||
'' intExtractions = intExtractions + 1 | |||
'' End If | |||
' Next | |||
' | |||
' ' Remove the trailing delimiter | |||
' 'mstrAtomsStringBuffer = Left$(mstrAtomsStringBuffer, Len(mstrAtomsStringBuffer) - 1) | |||
' | |||
' ' The reduced set of Pairs is now a unique set of delimited Atoms in mstrAtomsStringBuffer. | |||
' | |||
' ' Write the fresh Members data to file as the Members of the top Topic named | |||
' ' the value in 'TopicName' in a folder named by the value in 'TopicName' | |||
' With New clsFile | |||
' | |||
' ' Create a new top distribution if non-existant, | |||
' ' or query the user for overwrite permission, | |||
' ' else bail, no persistence -- no existence | |||
' Select Case .FileExists(mstrDataPath & "\" & TopicName & "\Members.txt") | |||
' | |||
' Case True | |||
' | |||
' If MsgBox("Overwrite the Members.txt file for Topic " & TopicName & "?", vbYesNo + vbQuestion + vbDefaultButton2, "Random distribution available") = vbYes Then | |||
' If .Save(mstrAtomsStringBuffer, UseAppend:=False) Then | |||
' ' Create (or err past if existing) a folder for the top node, named A1 | |||
' iFnData_ExtractAtoms = True | |||
' Else | |||
' RaiseEvent CommandResponse("Unable to save the Atoms extracted from Paired.txt to " & .Filespec) | |||
' MsgBox "Unable to save the Atoms extracted from Paired.txt to: " & .Filespec | |||
' End If | |||
' End If | |||
' | |||
' Case False | |||
' | |||
' ' Create the new Topic Folder | |||
' MkDir Root.DataPath & "\" & TopicName | |||
' | |||
' | |||
' If .Save(mstrAtomsStringBuffer) Then | |||
' RaiseEvent CommandResponse("Extracted Atoms saved to " & .Filespec) | |||
' iFnData_ExtractAtoms = True | |||
' Else | |||
' RaiseEvent CommandResponse("Unable to save the Atoms extracted from Paired.txt to: " & .Filespec) | |||
' MsgBox "Unable to save the Atoms extracted from Paired.txt to: " & .Filespec | |||
' End If | |||
' | |||
' End Select | |||
' End With | |||
' | |||
' RaiseEvent CommandResponse("Extraction of member atoms complete. " & CStr(intExtractions) & " members extracted.") | |||
' | |||
' Screen.MousePointer = vbDefault | |||
' | |||
'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 | |||
</div> | </div> |
Revision as of 11:43, 14 July 2023
About ∞ White paper ∞ QuasiMatrix Code ∞ QAT Code ∞ Data Examples ∞ Scatter-Gather Explained ∞ The Plow Share ∞
The Warehouse if Pairs Expansion then Visual Scatter else Visual Cluster redim Bracketing Clusters while Event Chemistry wend SLIP class redim
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 iFnData_ExtractAtoms(Optional ByVal TopicName As String = "A1") As Boolean
' Dim ndx As Long
' Dim lngCount As Long
' Dim strSplitPairs() As String 'array
'
' Dim lngLength As Long
' Dim strAtom As String
' Dim strPairs As String
' Dim intExtractions As Integer
'
' On Error Resume Next
'
' Screen.MousePointer = vbHourglass
'
' RaiseEvent CommandResponse("Extracting unique members from Paired.txt...")
'
'
' ' Flatten the inner and outer delimiters to the same (Replace "**" with CRLF )
' strPairs = Replace(strPairs, "**", vbCrLf)
'
' ' Split the delimited members to an array
' strSplitPairs = Split(strPairs, vbCrLf)
'
' ' Loop through array, checking for new Members from Pairs
' lngCount = UBound(strSplitPairs)
' For ndx = 0 To lngCount
' ' Test that the array element is in the Atoms buffer
If InStr(1, mstrAtomsStringBuffer, strSplitPairs(ndx)) = 0 Then 'not there
' Concatenate the new randomized atom to the buffer at the beginning
mstrAtomsStringBuffer = strSplitPairs(ndx) & vbTab & CStr(Int(Rnd * 360) + 1) & vbCrLf & mstrAtomsStringBuffer
intExtractions = intExtractions + 1
End If
' Next
'
' ' Remove the trailing delimiter
' 'mstrAtomsStringBuffer = Left$(mstrAtomsStringBuffer, Len(mstrAtomsStringBuffer) - 1)
'
' ' The reduced set of Pairs is now a unique set of delimited Atoms in mstrAtomsStringBuffer.
'
' ' Write the fresh Members data to file as the Members of the top Topic named
' ' the value in 'TopicName' in a folder named by the value in 'TopicName'
' With New clsFile
'
' ' Create a new top distribution if non-existant,
' ' or query the user for overwrite permission,
' ' else bail, no persistence -- no existence
' Select Case .FileExists(mstrDataPath & "\" & TopicName & "\Members.txt")
'
' Case True
'
' If MsgBox("Overwrite the Members.txt file for Topic " & TopicName & "?", vbYesNo + vbQuestion + vbDefaultButton2, "Random distribution available") = vbYes Then
' If .Save(mstrAtomsStringBuffer, UseAppend:=False) Then
' ' Create (or err past if existing) a folder for the top node, named A1
' iFnData_ExtractAtoms = True
' Else
' RaiseEvent CommandResponse("Unable to save the Atoms extracted from Paired.txt to " & .Filespec)
' MsgBox "Unable to save the Atoms extracted from Paired.txt to: " & .Filespec
' End If
' End If
'
' Case False
'
' ' Create the new Topic Folder
' MkDir Root.DataPath & "\" & TopicName
'
'
' If .Save(mstrAtomsStringBuffer) Then
' RaiseEvent CommandResponse("Extracted Atoms saved to " & .Filespec)
' iFnData_ExtractAtoms = True
' Else
' RaiseEvent CommandResponse("Unable to save the Atoms extracted from Paired.txt to: " & .Filespec)
' MsgBox "Unable to save the Atoms extracted from Paired.txt to: " & .Filespec
' End If
'
' End Select
' End With
'
' RaiseEvent CommandResponse("Extraction of member atoms complete. " & CStr(intExtractions) & " members extracted.")
'
' Screen.MousePointer = vbDefault
'
'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