VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form monitor_freq
AutoRedraw = -1 'True
Caption = "Frequency"
ClientHeight = 3795
ClientLeft = 60
ClientTop = 630
ClientWidth = 7350
LinkTopic = "Form1"
MaxButton = 0 'False
MDIChild = -1 'True
ScaleHeight = 3795
ScaleWidth = 7350
Tag = "0"
Visible = 0 'False
Begin VB.CheckBox chkNotzero
Caption = ">0"
Height = 195
Left = 5520
TabIndex = 5
ToolTipText = "Only values >0 (when other variable selected for mean calculation)"
Top = 60
Width = 555
End
Begin VB.PictureBox Picture1
AutoRedraw = -1 'True
BackColor = &H00FFFFFF&
Height = 1275
Left = 840
OLEDragMode = 1 'Automatic
OLEDropMode = 2 'Automatic
ScaleHeight = 1215
ScaleWidth = 1335
TabIndex = 7
TabStop = 0 'False
Top = 2220
Width = 1395
End
Begin VB.ComboBox Combo2
Height = 315
ItemData = "monitor_freq.frx":0000
Left = 4020
List = "monitor_freq.frx":0002
Sorted = -1 'True
TabIndex = 4
Text = "Frequency"
ToolTipText = "Show frequency or mean for another variable chosen here"
Top = 0
Width = 1455
End
Begin VB.CheckBox chkPlot
Caption = "Plot"
Height = 255
Left = 2460
TabIndex = 3
ToolTipText = "Show miniplot (select column)"
Top = 0
Width = 675
End
Begin VB.CheckBox chkPercent
Caption = "Percent"
Height = 255
Left = 1500
TabIndex = 2
ToolTipText = "Show percent instead of counts"
Top = 0
Width = 915
End
Begin VB.ComboBox Combo1
Height = 315
ItemData = "monitor_freq.frx":0004
Left = 0
List = "monitor_freq.frx":0006
Sorted = -1 'True
TabIndex = 1
ToolTipText = "Select variable"
Top = 0
Width = 1455
End
Begin VB.TextBox Text1
Height = 315
Left = 3720
TabIndex = 6
Top = 1080
Width = 795
Visible = 0 'False
End
Begin ComctlLib.ListView lv1
Height = 1755
Left = 0
TabIndex = 0
TabStop = 0 'False
Top = 300
Width = 4575
_ExtentX = 8070
_ExtentY = 3096
View = 3
LabelWrap = -1 'True
HideSelection = -1 'True
_Version = 327682
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 0
End
Begin VB.Label lblStat
Alignment = 2 'Center
Caption = "Stat"
Height = 195
Left = 0
TabIndex = 10
Top = 2700
Width = 855
End
Begin VB.Label max
Alignment = 1 'Right Justify
Caption = "max"
Height = 195
Left = 0
TabIndex = 9
Top = 2220
Width = 735
End
Begin VB.Label min
Alignment = 1 'Right Justify
Caption = "min"
Height = 195
Left = 0
TabIndex = 8
Top = 3540
Width = 735
End
Begin VB.Menu menuclear
Caption = "&Clear"
End
Begin VB.Menu menucopytoeditor
Caption = "Copy to &editor"
End
End
Attribute VB_Name = "monitor_freq"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Option Base 1
Dim last_chosen_var As String, last_chosen_meanvar As String, last_chosen_header As String
Dim nfreq As Integer, meanflag As Integer
Dim display_price_level As Integer 'At load only
Private Sub chkNotzero_Click()
Call call_which
End Sub
Private Sub chkPercent_Click()
Call menuClear_Click
Call call_which
End Sub
Public Sub Combo1_Click()
Combo1.Width = 1455
chkPlot.SetFocus
Call call_which
End Sub
Private Sub Combo1_DropDown()
Combo1.Width = Combo1.Width * 3
End Sub
Private Sub Combo2_DropDown()
Combo2.Left = Combo2.Left - Combo1.Width * 2
Combo2.Width = Combo1.Width * 3
End Sub
Private Sub Combo1_LostFocus()
Combo1.Width = 1455
End Sub
Private Sub Combo2_LostFocus()
Combo2.Left = 4020
Combo2.Width = 1455
End Sub
Public Sub Combo2_Click()
Combo2.Left = 4020
Combo2.Width = 1455
chkPlot.SetFocus
Call call_which
End Sub
Private Sub call_which()
Dim i As Long
Dim combo1txt As String, combo2txt As String
If Combo2.text = "Frequency" Then
chkNotzero.enabled = False
chkPercent.enabled = True
Else
chkNotzero.enabled = True
chkPercent.enabled = False
End If
combo1txt = getword(Combo1.text, 1, " ")
combo2txt = getword(Combo2.text, 1, " ")
If combo1txt = "" Then Exit Sub
' New variable
If combo1txt <> last_chosen_var _
Or combo2txt <> last_chosen_meanvar Then
Call menuClear_Click
End If
last_chosen_var = combo1txt
last_chosen_meanvar = combo2txt
meanflag = 0
If Mid$(combo1txt, 1, 1) = Mid$(combo2txt, 1, 1) Then
meanflag = 1
Call prepare_temp(combo2txt)
For i = 1 To UBound(temp)
temp2(i) = temp(i) * m_price99 ^ display_price_level
Next
End If
Call prepare_temp(combo1txt)
Call stat_ber(temp)
End Sub
Private Sub Form_Load()
display_price_level = 0
If controlcenter.chk2Price99.value = 1 Then
display_price_level = 1
Me.Caption = "Frequency (1999) "
End If
Me.Height = 2550
'Me.Width = 5745
Me.Width = 6500
lv1.Width = Me.Width - 200
lv1.Height = (Me.Height - 300) - 400
' Fetch variable names
Dim cv
Combo2.AddItem "Frequency"
' For Each cv In var_coll
For Each cv In varcom_coll
Combo1.AddItem cv
Combo2.AddItem cv
Next
lv1.ColumnHeaders.Clear
lv1.ListItems.Clear
Call call_which
Combo1.Refresh
End Sub
Private Sub Form_Resize()
If Me.WindowState = vbMinimized Then Exit Sub
If chkPlot.value = 0 Then
Picture1.Visible = False
lblStat.Visible = False
max.Visible = False
min.Visible = False
lv1.Height = (Me.Height - 300) - 400
lv1.Width = Me.Width - 200
Else
Picture1.Visible = True
lblStat.Visible = True
max.Visible = True
min.Visible = True
lv1.Width = maxi(200, Me.Width - 200)
lv1.Height = maxi(200, Me.Height / 1.7 - 300 - 400)
Picture1.Top = lv1.Top + lv1.Height + 100
max.Top = Picture1.Top
Picture1.Height = maxi(200, Me.Height - lv1.Top - lv1.Height - 600)
Picture1.Width = Picture1.Height * 2
min.Top = Me.Height - 700
lblStat.Top = max.Top + (min.Top - max.Top) / 2
Call plotnew
End If
End Sub
Private Sub chkPlot_Click()
If chkPlot.value = 1 Then
Me.Height = Me.Height * 1.7
Else
Me.Height = Me.Height / 1.7
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
coll_view.Remove Me.Tag
End Sub
Private Sub menuClear_Click()
lv1.ColumnHeaders.Clear
lv1.ListItems.Clear
nfreq = 0
End Sub
Private Sub menuCopytoeditor_Click()
Dim i As Integer, j As Integer
Dim txt As String
txt = frmEditor.rtbLog.text
txt = txt + vbCrLf
txt = txt + "Variable: " + Combo1.text
If Combo2.text = "Frequency" Then
txt = txt + " (frequency)" + vbCrLf
Else
txt = txt + " (mean of " + Combo2.text + ")" + vbCrLf
End If
For i = 1 To lv1.ColumnHeaders.count
txt = txt + fspace(lv1.ColumnHeaders(i), 10)
Next
txt = txt + vbCrLf
For i = 1 To lv1.ListItems.count
txt = txt + fspace(lv1.ListItems(i), 10)
For j = 1 To lv1.ColumnHeaders.count - 1
txt = txt + fspace(lv1.ListItems.Item(i).SubItems(j), 10)
Next
txt = txt + vbCrLf
Next
frmEditor.rtbLog.text = txt
' Copy txt also to clipboard
Clipboard.Clear
Clipboard.SetText txt
End Sub
Private Sub Text1_Change()
Dim i As Long
If Text1.text = "Clear" Then
lv1.ColumnHeaders.Clear
lv1.ListItems.Clear
nfreq = 0
Exit Sub
End If
Call call_which
If chkPlot = 1 Then Call plotnew
End Sub
Private Sub stat_ber(x)
Dim i As Long, j As Long, n As Long
Dim sum As Double
Dim only_positive_values As Integer, nfreq_old As Integer, freqnr As Integer
Static freq(106, 3) As Double
Dim freqtemp(105, 3) As Double
nfreq_old = nfreq
only_positive_values = 0
If chkPercent = 1 Then only_positive_values = 1
' Clear
For i = 1 To 106
freq(i, 2) = 0 ' counter
freq(i, 3) = 0 ' mean
Next
' Individuals or households
Dim temp_sel() As Long
If Mid$(Combo1.text, 1, 1) = "i" Then
n = m_icount
temp_sel = select_i
Else
n = m_hcount
temp_sel = select_h
End If
For i = 1 To n
If temp_sel(i) = 1 Then
If only_positive_values = 0 Or _
only_positive_values = 1 And x(i) >= 0 Then
freqnr = 0
For j = 1 To nfreq
If freq(j, 1) = x(i) Then
freqnr = j
Exit For
End If
Next
If freqnr = 0 Then
freqnr = nfreq + 1
If freqnr > 105 Then freqnr = 106
freq(freqnr, 1) = x(i)
End If
If freqnr > nfreq Then nfreq = freqnr
' Frequency
freq(freqnr, 2) = freq(freqnr, 2) + 1
' Mean
If meanflag = 1 Then
If chkNotzero.value = 0 Or (chkNotzero.value = 1 And temp2(i) > 0) Then
freq(freqnr, 3) = (freq(freqnr, 2) - 1) / freq(freqnr, 2) * freq(freqnr, 3) _
+ 1 / freq(freqnr, 2) * temp2(i)
End If
End If
End If
End If
Next
' Sort
If nfreq > 1 Then
' make copy
For i = 1 To mini(105, nfreq)
freqtemp(i, 1) = freq(i, 1)
freqtemp(i, 2) = freq(i, 2)
freqtemp(i, 3) = freq(i, 3)
Next
Dim minf As Long
Dim minnr As Integer
minf = 999999999#
minnr = 0
For i = 1 To mini(105, nfreq)
For j = 1 To mini(105, nfreq)
If freqtemp(j, 1) < minf Then
minnr = j
minf = freqtemp(j, 1)
End If
Next
freq(i, 1) = freqtemp(minnr, 1)
freq(i, 2) = freqtemp(minnr, 2)
freq(i, 3) = freqtemp(minnr, 3)
minf = 999999999#
freqtemp(minnr, 1) = minf
Next
End If
lv1.Visible = False
' Control is empty
If lv1.ColumnHeaders.count = 0 Then
lv1.ColumnHeaders.add , , "Time", 300
For i = 1 To mini(105, nfreq)
lv1.ColumnHeaders.add , , CStr(freq(i, 1)), 550
Next
If nfreq = 106 Then lv1.ColumnHeaders.add , , "Other", 550
End If
' Check if we need to add or insert a new frequency
For i = 1 To mini(105, nfreq)
' Adding
If i > lv1.ColumnHeaders.count - 1 Then
lv1.ColumnHeaders.add , , CStr(freq(i, 1)), 550
For j = 1 To lv1.ListItems.count
lv1.ListItems.Item(j).SubItems(i) = "0"
Next
' Inserting
Else
If CStr(freq(i, 1)) <> getword(lv1.ColumnHeaders.Item(i + 1), 1, " ") Then
Call insert_col(i, CStr(freq(i, 1)))
End If
End If
Next
' The last col
If nfreq = 106 And 106 > lv1.ColumnHeaders.count - 1 Then
lv1.ColumnHeaders.add , , "Other", 550
For j = 1 To lv1.ListItems.count
lv1.ListItems.Item(j).SubItems(i) = "0"
Next
End If
sum = 0
For i = 1 To nfreq
sum = sum + freq(i, 2)
Next
Dim m
Set m = lv1.ListItems.add()
m.text = CStr(base_year + model_time)
For i = 1 To nfreq
If chkPercent = 0 Then
If meanflag = 0 Then
m.SubItems(i) = freq(i, 2) * m_weight
Else
If freq(i, 3) < 5 Then
m.SubItems(i) = round(freq(i, 3), 3)
Else
m.SubItems(i) = round(freq(i, 3), 1)
End If
End If
Else
If sum > 0 Then
m.SubItems(i) = round(freq(i, 2) / sum * 100, 2)
Else
m.SubItems(i) = 0
End If
End If
Next
' Select last item
Dim nlist As Integer
nlist = lv1.ListItems.count
Set lv1.SelectedItem = lv1.ListItems(nlist)
lv1.Visible = True
lv1.Refresh
Me.Caption = "Freq: " & Combo1.text
If display_price_level = 1 Then Me.Caption = "Freq: (1999)" & Combo1.text
'controlcenter.chkSelection.Caption = exclude_txt
Call delete_duplicate
Call explain_status
End Sub
Private Sub explain_status()
Dim i As Integer
If last_chosen_var <> "i_status" And last_chosen_var <> "i_status_old" Then Exit Sub
For i = 2 To lv1.ColumnHeaders.count
Select Case lv1.ColumnHeaders.Item(i)
Case "1"
lv1.ColumnHeaders.Item(i) = "1 Child"
Case "2"
lv1.ColumnHeaders.Item(i) = "2 Agepens"
Case "3"
lv1.ColumnHeaders.Item(i) = "3 Stud"
Case "4"
lv1.ColumnHeaders.Item(i) = "4 Disabled"
Case "5"
lv1.ColumnHeaders.Item(i) = "5 Parent"
Case "6"
lv1.ColumnHeaders.Item(i) = "6 Unemp"
Case "7"
lv1.ColumnHeaders.Item(i) = "7 Misc"
Case "8"
lv1.ColumnHeaders.Item(i) = "8 Work"
Case "9"
lv1.ColumnHeaders.Item(i) = "9 Emig"
End Select
Next
End Sub
Public Sub delete_duplicate()
Dim i As Integer, nduplicate As Integer
nduplicate = 0
If lv1.ListItems.count >= 2 Then
If lv1.ListItems.Item(lv1.ListItems.count) = lv1.ListItems.Item(lv1.ListItems.count - 1) Then nduplicate = nduplicate + 1
For i = 1 To nfreq
If lv1.ListItems.Item(lv1.ListItems.count).SubItems(i) = lv1.ListItems.Item(lv1.ListItems.count - 1).SubItems(i) Then nduplicate = nduplicate + 1
Next
End If
If nduplicate = nfreq + 1 Then
lv1.ListItems.Remove (lv1.ListItems.count)
End If
End Sub
Private Sub insert_col(aftercolnr, txt)
Dim i As Integer, j As Integer
lv1.ColumnHeaders.add , , lv1.ColumnHeaders(lv1.ColumnHeaders.count), 550
For i = lv1.ColumnHeaders.count - 1 To aftercolnr + 1 Step -1
lv1.ColumnHeaders.Item(i) = lv1.ColumnHeaders.Item(i - 1)
For j = 1 To lv1.ListItems.count
lv1.ListItems.Item(j).SubItems(i) = lv1.ListItems.Item(j).SubItems(i - 1)
Next
Next
lv1.ColumnHeaders.Item(aftercolnr + 1) = txt
For j = 1 To lv1.ListItems.count
lv1.ListItems.Item(j).SubItems(aftercolnr) = "0"
Next
End Sub
' **********************************************
' Miniplot
' **********************************************
Private Sub lv1_ColumnClick(ByVal ColumnHeader As ComctlLib.ColumnHeader)
Dim i As Integer
If ColumnHeader = "Time" Then Exit Sub
last_chosen_header = getword(ColumnHeader, 1, " ")
For i = 1 To lv1.ColumnHeaders.count
If getword(lv1.ColumnHeaders(i), 1, " ") = getword(ColumnHeader, 1, " ") Then Exit For
Next
If i > 1 And chkPlot = 1 Then
Call plotnew
End If
End Sub
Private Sub plotnew()
Dim n As Integer, i As Integer, colnr As Integer
Dim y() As Double, miny As Double, maxy As Double
Static oldcolnr As Integer
For colnr = 1 To lv1.ColumnHeaders.count
If getword(lv1.ColumnHeaders(colnr), 1, " ") = last_chosen_header Then Exit For
Next
If colnr = 0 Or colnr > lv1.ColumnHeaders.count Then Exit Sub
' If no items - exit
n = lv1.ListItems.count
If n = 0 Then Exit Sub
' If colnr=0 - redraw
If colnr = 0 And oldcolnr = 0 Then Exit Sub
If colnr = 0 Then colnr = oldcolnr
oldcolnr = colnr
' Fill plot-vector with values and compute max and min
ReDim y(1 To n)
maxy = -999999999
miny = 999999999
For i = 1 To n
' Exit if there are no values
If IsNumeric(lv1.ListItems(i).SubItems(colnr - 1)) = False Then Exit Sub
y(i) = val(lv1.ListItems(i).SubItems(colnr - 1))
If y(i) > maxy Then maxy = y(i)
If y(i) < miny Then miny = y(i)
Next
miny = miny * 0.95
maxy = maxy * 1.05
If miny = maxy Then
miny = miny - 1
maxy = maxy + 1
End If
If n = 1 Then
n = 2
ReDim Preserve y(1 To n)
y(2) = y(1)
End If
' Set scale for upper-left and lower-right
Picture1.Cls
Picture1.Scale (1, maxy)-(n, miny)
For i = 2 To n
Picture1.Line (i - 1, y(i - 1))-(i, y(i)), QBColor(0)
Next
lblStat.Caption = lv1.ColumnHeaders(colnr)
Dim dec As Integer
Dim minyl As Double, maxyl As Double
minyl = miny
maxyl = maxy
If maxyl > 1000000 Then
maxyl = maxyl / 1000000
minyl = minyl / 1000000
End If
dec = 3
If Abs(maxyl) > 10 Then dec = 2
If Abs(maxyl) > 100 Then dec = 1
If Abs(maxyl) > 1000 Then dec = 0
max.Caption = round(maxyl, dec)
min.Caption = round(minyl, dec)
End Sub
Static Function Log10(x)
Log10 = Log(x) / Log(10#)
End Function