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