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