VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Begin VB.Form form_contingency
Caption = "Contingency Table Form"
ClientHeight = 3495
ClientLeft = 45
ClientTop = 270
ClientWidth = 4290
DrawStyle = 1 'Dash
LinkTopic = "Form1"
MDIChild = -1 'True
ScaleHeight = 3495
ScaleWidth = 4290
Tag = "contingency"
Begin VB.TextBox Text1
Height = 285
Left = 8160
TabIndex = 7
Text = "Text1"
Top = 4920
Width = 975
Visible = 0 'False
End
Begin VB.Frame Frame2
Caption = "Column Variable"
Height = 1335
Left = 2160
TabIndex = 6
Top = 120
Width = 1935
Begin VB.CommandButton scale_var
Caption = "Change View"
Enabled = 0 'False
Height = 375
Index = 2
Left = 240
TabIndex = 4
Top = 840
Width = 1455
End
Begin VB.ComboBox Combo2
Height = 315
Left = 240
TabIndex = 2
ToolTipText = "Choose variable to be displayed in columns"
Top = 360
Width = 1455
End
End
Begin VB.Frame Frame1
Caption = "Row Variable"
Height = 1335
Left = 120
TabIndex = 5
Top = 120
Width = 1935
Begin VB.CommandButton scale_var
Caption = "Change View"
Enabled = 0 'False
Height = 375
Index = 1
Left = 240
TabIndex = 3
Top = 840
Width = 1455
End
Begin VB.ComboBox Combo1
Height = 315
Left = 240
TabIndex = 1
ToolTipText = "Choose variable to be displayed in rows"
Top = 360
Width = 1455
End
End
Begin MSFlexGridLib.MSFlexGrid MSFlexGrid1
Height = 1815
Left = 0
TabIndex = 0
TabStop = 0 'False
ToolTipText = "Tabellen!!"
Top = 1560
Width = 4155
_ExtentX = 7329
_ExtentY = 3201
_Version = 393216
End
End
Attribute VB_Name = "form_contingency"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Option Base 1
Dim data() As Long
Dim rowclasses As Double
Dim colclasses As Double
Dim grid_row() As Double
Dim grid_col() As Double
Dim dimension As Integer
Dim minrow As Double, mincol As Double, maxrow As Double, maxcol As Double
Dim rowvar As Boolean, colvar As Boolean, rowinteger As Boolean, colinteger As Boolean
Dim last_combo_clicked As Long
Dim operatorcoll As New Collection
'******************************************************
Private Sub Form_Load()
Dim i As Integer, j As Integer
Dim slump As Double
Me.Width = 5000
Me.Height = 4470
operatorcoll.add "GT"
operatorcoll.add "GE"
operatorcoll.add "LE"
operatorcoll.add "LT"
operatorcoll.add "EQ"
operatorcoll.add "NE"
Dim x As Variant
For Each x In var_coll
Combo1.AddItem x
Combo2.AddItem x
Next x
'no variables selected yet
dimension = 0
rowvar = False
colvar = False
colinteger = False
rowinteger = False
MSFlexGrid1.Cols = 1
MSFlexGrid1.Rows = 1
End Sub
'******************************************************
Private Sub Form_Unload(Cancel As Integer)
coll_view.Remove Me.Tag
End Sub
'******************************************************
Private Sub Combo1_Click()
' Only individual variables so far
If Mid(Combo1.text, 1, 1) <> "i" Then Exit Sub
If Combo1.text = Combo2.text And Combo1.text <> "" Then
Combo1.text = ""
Else
last_combo_clicked = 1
Call make_grid
Call update_combo2
Call change_variable
End If
End Sub
'******************************************************
Private Sub Combo2_Click()
' Only individual variables so far
If Mid(Combo2.text, 1, 1) <> "i" Then Exit Sub
If Combo1.text = Combo2.text And Combo1.text <> "" Then
Combo2.text = ""
Else
last_combo_clicked = 2
Call make_grid
Call update_combo1
Call change_variable
End If
End Sub
'******************************************************
Sub change_variable()
If Combo1.text = "" And Combo2.text = "" Then
MSFlexGrid1.Rows = 1
MSFlexGrid1.Cols = 1
MSFlexGrid1.TextMatrix(0, 0) = "No data!"
Call min_cell_width
Else
dimension = 1
If Combo1.text <> "" And Combo2.text <> "" Then dimension = 2
If Combo1.text <> "" Then
scale_var(1).enabled = True
rowvar = True
Else
scale_var(1).enabled = False
rowvar = False
End If
If Combo2.text <> "" Then
scale_var(2).enabled = True
colvar = True
Else
scale_var(2).enabled = False
colvar = False
End If
Call prepare_data
Call write_grid
End If
End Sub
'******************************************************
Sub make_grid()
Select Case last_combo_clicked
Case 1
Call prepare_temp(Combo1.text)
If n_unique_values(temp) > 10 Then rowinteger = False Else rowinteger = True
If rowinteger Then
Call make_integerlist(temp, grid_row)
rowclasses = UBound(grid_row)
Else
Call make_classlimits(temp, grid_row)
rowclasses = UBound(grid_row) - 1
End If
Case 2
Call prepare_temp(Combo2.text)
If n_unique_values(temp) > 10 Then colinteger = False Else colinteger = True
If colinteger Then
Call make_integerlist(temp, grid_col)
colclasses = UBound(grid_col)
Else
Call make_classlimits(temp, grid_col)
colclasses = UBound(grid_col) - 1
End If
Case Else
End Select
End Sub
'******************************************************
'Makes a list of all values in vector data in ascending order
Sub make_integerlist(data() As Variant, grid() As Double)
Dim nvalues As Long, i As Long, grididx As Long
Dim tempvec() As Variant
ReDim tempvec(UBound(data)) As Variant
tempvec = data
Call CombSort(tempvec)
nvalues = n_unique_values(tempvec)
ReDim grid(nvalues) As Double
grididx = 1
grid(grididx) = tempvec(1)
For i = 2 To m_icount
If tempvec(i) <> tempvec(i - 1) Then
grididx = grididx + 1
grid(grididx) = tempvec(i)
End If
Next
End Sub
'******************************************************
'Makes a list of class limits for vector data using 10 classes from min to max
Sub make_classlimits(data() As Variant, grid() As Double)
Dim min As Double, max As Double, classes As Long, i As Long
Call checkminmax(data, min, max)
'10 classes is default for continuous variables
classes = 10
ReDim grid(classes + 1) As Double
grid(1) = min
grid(classes + 1) = max
For i = 2 To classes
grid(i) = grid(i - 1) + (max - min) / classes
Next
End Sub
'******************************************************
Sub prepare_data()
Dim i As Long, j As Long, k As Long
Select Case dimension
Case 1
If rowvar Then
Call prepare_temp(Combo1.text)
ReDim data(rowclasses) As Long
For i = 1 To m_icount
If select_i(i) = 1 Then
For j = 1 To rowclasses
If rowinteger Then
If grid_row(j) = temp(i) Then
data(j) = data(j) + 1
Exit For
End If
Else
If grid_row(j) < temp(i) And grid_row(j + 1) >= temp(i) Then
data(j) = data(j) + 1
Exit For
End If
End If
Next
End If
Next
Else
Call prepare_temp(Combo2.text)
ReDim data(colclasses) As Long
For i = 1 To m_icount
If select_i(i) = 1 Then
For j = 1 To colclasses
If colinteger Then
If grid_col(j) = temp(i) Then
data(j) = data(j) + 1
Exit For
End If
Else
If grid_col(j) < temp(i) And grid_col(j + 1) >= temp(i) Then
data(j) = data(j) + 1
Exit For
End If
End If
Next
End If
Next
End If
'Rescale to population weights
For i = 1 To UBound(data)
data(i) = data(i) * m_weight
Next i
Case 2
Call prepare_temp(Combo2.text)
temp2 = temp
Call prepare_temp(Combo1.text)
ReDim data(rowclasses, colclasses) As Long
For i = 1 To m_icount
If select_i(i) = 1 Then
For j = 1 To rowclasses
For k = 1 To colclasses
If rowinteger And colinteger Then
If temp(i) = grid_row(j) And temp2(i) = grid_col(k) Then
data(j, k) = data(j, k) + 1
Exit For
End If
End If
If rowinteger And (Not colinteger) Then
If temp(i) = grid_row(j) And temp2(i) >= grid_col(k) And temp2(i) < grid_col(k + 1) Then
data(j, k) = data(j, k) + 1
Exit For
End If
End If
If (Not rowinteger) And colinteger Then
If temp(i) >= grid_row(j) And temp(i) < grid_row(j + 1) And temp2(i) = grid_col(k) Then
data(j, k) = data(j, k) + 1
Exit For
End If
End If
If (Not rowinteger) And (Not colinteger) Then
If temp(i) >= grid_row(j) And temp(i) < grid_row(j + 1) And _
temp2(i) >= grid_col(k) And temp2(i) < grid_col(k + 1) Then
data(j, k) = data(j, k) + 1
Exit For
End If
End If
Next
Next
End If
Next
'Rescale to population weight
For i = 1 To rowclasses
For j = 1 To colclasses
data(i, j) = data(i, j) * m_weight
Next j
Next i
Case Else
End Select
End Sub
'******************************************************
Sub write_grid()
Dim i As Integer, j As Integer
Select Case dimension
Case 1
If rowvar Then
MSFlexGrid1.Rows = rowclasses + 1
MSFlexGrid1.Cols = 2
MSFlexGrid1.TextMatrix(0, 1) = Combo1.text
MSFlexGrid1.TextMatrix(0, 0) = ""
For i = 1 To rowclasses
If rowinteger Then
MSFlexGrid1.TextMatrix(i, 0) = grid_row(i)
Else
MSFlexGrid1.TextMatrix(i, 0) = round(grid_row(i), 1) & " -"
End If
MSFlexGrid1.TextMatrix(i, 1) = data(i)
Next
Else
MSFlexGrid1.Rows = 2
MSFlexGrid1.Cols = colclasses + 1
MSFlexGrid1.TextMatrix(1, 0) = Combo2.text
MSFlexGrid1.TextMatrix(0, 0) = ""
For i = 1 To colclasses
If colinteger Then
MSFlexGrid1.TextMatrix(0, i) = grid_col(i)
Else
MSFlexGrid1.TextMatrix(0, i) = round(grid_col(i), 1) & " -"
End If
MSFlexGrid1.TextMatrix(1, i) = data(i)
Next
End If
Case 2
MSFlexGrid1.Cols = colclasses + 1
MSFlexGrid1.Rows = rowclasses + 1
' MSFlexGrid1.TextMatrix(0, 0) = Combo1.text & " \ " & Combo2.text
For i = 1 To rowclasses
If rowinteger Then
MSFlexGrid1.TextMatrix(i, 0) = grid_row(i)
Else
MSFlexGrid1.TextMatrix(i, 0) = round(grid_row(i), 1) & " -"
End If
Next
For i = 1 To colclasses
If colinteger Then
MSFlexGrid1.TextMatrix(0, i) = grid_col(i)
Else
MSFlexGrid1.TextMatrix(0, i) = round(grid_col(i), 1) & " -"
End If
Next
For i = 1 To rowclasses
For j = 1 To colclasses
MSFlexGrid1.TextMatrix(i, j) = data(i, j)
Next
Next
End Select
Call min_cell_width
End Sub
'******************************************************
'Set minimal column width
Private Sub min_cell_width()
Dim maxrowlength As Long
Dim i As Integer, j As Integer
Dim text As String
MSFlexGrid1.Redraw = False
For i = 0 To MSFlexGrid1.Cols - 1
maxrowlength = 0
For j = 0 To MSFlexGrid1.Rows - 1
If Len(MSFlexGrid1.TextMatrix(j, i)) > maxrowlength Then
maxrowlength = Len(MSFlexGrid1.TextMatrix(j, i))
End If
Next j
' MSFlexGrid1.ColWidth(i) = MSFlexGrid1.CellFontSize * maxrowlength * 12
MSFlexGrid1.ColWidth(i) = maxrowlength * 120
If MSFlexGrid1.ColWidth(i) < 250 Then MSFlexGrid1.ColWidth(i) = 250
Next i
MSFlexGrid1.Redraw = True
MSFlexGrid1.Refresh
End Sub
'******************************************************
Sub update_combo1()
Dim oldtext As String
If Combo2.text = "" Then scale_var(2).enabled = False
oldtext = Combo1.text
Combo1.Clear
Dim x As Variant
For Each x In var_coll
If Combo2.text <> x Then Combo1.AddItem x
Next x
Combo1.text = oldtext
End Sub
'******************************************************
Sub update_combo2()
Dim oldtext As String
If Combo1.text = "" Then scale_var(1).enabled = False
oldtext = Combo2.text
Combo2.Clear
Dim x As Variant
For Each x In var_coll
If Combo1.text <> x Then Combo2.AddItem x
Next x
Combo2.text = oldtext
End Sub
'******************************************************
Private Sub combo1_KeyUp(KeyCode As Integer, Shift As Integer)
Dim x As Variant
For Each x In var_coll
If Combo1.text = x Or Combo1.text = "" Then Call Combo1_Click
Next
End Sub
'******************************************************
Private Sub combo2_KeyUp(KeyCode As Integer, Shift As Integer)
Dim x As Variant
For Each x In var_coll
If Combo2.text = x Or Combo2.text = "" Then Call Combo2_Click
Next
End Sub
'******************************************************
Private Sub scale_var_Click(index As Integer)
Dim text As String
If index = 1 Then text = Combo1.text Else text = Combo2.text
dlg_change_view.Show
dlg_change_view.Caption = "Change View - " & text
If index = 1 Then
If rowinteger = False Then
dlg_change_view.op_continous.value = True
Call prepare_temp(Combo1.text)
Call checkminmax(temp, minrow, maxrow)
dlg_change_view.txtMin = minrow
dlg_change_view.txtMax = maxrow
dlg_change_view.txtStep = rowclasses
Else
dlg_change_view.op_integer.value = True
dlg_change_view.txtMin.enabled = False
dlg_change_view.txtMax.enabled = False
dlg_change_view.txtStep.enabled = False
End If
End If
If index = 2 Then
If colinteger = False Then
dlg_change_view.op_continous.value = True
Call prepare_temp(Combo2.text)
Call checkminmax(temp, mincol, maxcol)
dlg_change_view.txtMin = mincol
dlg_change_view.txtMax = maxcol
dlg_change_view.txtStep = colclasses
Else
dlg_change_view.op_integer.value = True
End If
End If
End Sub
'******************************************************
Private Sub Form_Resize()
If Me.Width > 5000 Then
MSFlexGrid1.Width = Me.Width - 200
MSFlexGrid1.Visible = True
Else
Me.Width = 5000
' MSFlexGrid1.Visible = False
End If
If Me.Height > 2000 Then
MSFlexGrid1.Height = Me.Height - 2000
MSFlexGrid1.Visible = True
Else
MSFlexGrid1.Visible = False
End If
End Sub
'******************************************************
Sub CombSort(arr As Variant, Optional numEls As Variant, Optional descending As Boolean)
Dim value As Variant
Dim index As Long
Dim firstItem As Long
Dim Gap As Long
Dim Swap As Boolean
' account for optional arguments
If IsMissing(numEls) Then numEls = UBound(arr)
firstItem = LBound(arr)
Gap = numEls - firstItem + 1
Do While (Gap > 1 Or Swap)
' divide Gap by 1.3 - the author says it's an empirical value
Gap = (10 * Gap) \ 13
' another empirical value
If (Gap = 9 Or Gap = 10) Then Gap = 11
Swap = False
For index = firstItem To numEls - Gap
value = arr(index)
If (value > arr(index + Gap)) Xor descending Then
' if the items are not in order, swap them
arr(index) = arr(index + Gap)
arr(index + Gap) = value
Swap = True
End If
Next
Loop
End Sub
'******************************************************
Sub checkminmax(arr As Variant, min As Double, max As Double)
Dim i As Long
If UBound(arr) > 1 Then
min = arr(1)
max = arr(1)
Else
Exit Sub
End If
For i = 1 To UBound(arr)
If arr(i) < min Then min = arr(i)
If arr(i) > max Then max = arr(i)
Next i
End Sub
Function n_unique_values(ByVal arr As Variant) As Long
Dim i As Long, j As Long, sum As Long
Dim copyarr() As Variant
ReDim copyarr(UBound(arr)) As Variant
copyarr = arr
sum = 1
Call CombSort(copyarr)
For i = 2 To UBound(arr)
If copyarr(i - 1) <> copyarr(i) Then sum = sum + 1
Next
n_unique_values = sum
End Function
'******************************************************
'The SESIM-system updates all viewers by writing a random number into text1.text
Private Sub Text1_Change()
Call prepare_data
Call write_grid
End Sub