VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form monitor_univariate
AutoRedraw = -1 'True
Caption = "Univariate"
ClientHeight = 3900
ClientLeft = 60
ClientTop = 630
ClientWidth = 6795
LinkTopic = "Form1"
MaxButton = 0 'False
MDIChild = -1 'True
ScaleHeight = 3900
ScaleWidth = 6795
Tag = "0"
Visible = 0 'False
Begin VB.CheckBox chkPlot
Caption = "Plot"
Height = 195
Left = 2940
TabIndex = 2
ToolTipText = "Show mini-plot (click column header)"
Top = 60
Width = 795
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 = 8
TabStop = 0 'False
Top = 2220
Width = 1395
End
Begin VB.CheckBox chkNotzero
Caption = ">0"
Height = 195
Left = 4260
TabIndex = 3
ToolTipText = "Include only values larger than 0"
Top = 60
Width = 555
End
Begin VB.ComboBox Combo1
Height = 315
ItemData = "monitor_univariate.frx":0000
Left = 0
List = "monitor_univariate.frx":0002
Sorted = -1 'True
TabIndex = 1
ToolTipText = "Select variable"
Top = 0
Width = 2775
End
Begin VB.TextBox Text1
Height = 315
Left = 3720
TabIndex = 4
Top = 1080
Width = 795
Visible = 0 'False
End
Begin ComctlLib.ListView lv1
Height = 1755
Left = 0
TabIndex = 0
TabStop = 0 'False
ToolTipText = "Click column header to plot"
Top = 300
Width = 5535
_ExtentX = 9763
_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 min
Alignment = 1 'Right Justify
Caption = "min"
Height = 195
Left = 0
TabIndex = 7
Top = 3540
Width = 735
End
Begin VB.Label max
Alignment = 1 'Right Justify
Caption = "max"
Height = 195
Left = 0
TabIndex = 6
Top = 2220
Width = 735
End
Begin VB.Label lblStat
Alignment = 2 'Center
Caption = "Stat"
Height = 195
Left = 0
TabIndex = 5
Top = 2700
Width = 855
End
Begin VB.Menu menuClear
Caption = "&Clear"
End
Begin VB.Menu menuCopytoeditor
Caption = "Copy to &editor"
End
End
Attribute VB_Name = "monitor_univariate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Option Base 1
Public stat_summa As Double, stat_medel As Double, stat_std As Double
Public stat_min As Double, stat_max As Double, stat_atkinson As Double
Public stat_antalmedvärde As Long
Dim last_chosen_var As String
Dim display_price_level As Integer 'At load only
Private Sub chkNotzero_Click()
' Call stat_ber(temp)
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.Width = Me.Width - 200
lv1.Height = (Me.Height - 300) - 400
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 = Me.Width - Picture1.Left - 200
min.Top = Me.Height - 700
lblStat.Top = max.Top + (min.Top - max.Top) / 2
Call plotnew(0)
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
Public Sub Combo1_Click()
chkPlot.SetFocus
Call call_which
End Sub
Private Sub Form_Load()
display_price_level = 0
If controlcenter.chk2Price99.value = 1 Then
display_price_level = 1
Me.Caption = "Univariate (1999 prices)"
End If
Me.Height = 2550
Me.Width = 7200
lv1.Width = Me.Width - 200
lv1.Height = (Me.Height - 300) - 400
'*** Populate the listboxes
' Individual- and household variables
Dim cv
For Each cv In varcom_coll
Combo1.AddItem cv
Next
' macro variables
For Each cv In mvar_coll
Combo1.AddItem cv
Next
lv1.ColumnHeaders.Clear
lv1.ColumnHeaders.add , , "Time", 400
lv1.ColumnHeaders.add , , "Mean", 600
lv1.ColumnHeaders.add , , "Sum", 600
lv1.ColumnHeaders.add , , "Std", 600
lv1.ColumnHeaders.add , , "Min", 600
lv1.ColumnHeaders.add , , "Max", 600
lv1.ColumnHeaders.add , , "Count>0", 600
lv1.ColumnHeaders.add , , "Atkin", 600
' lv1.ColumnHeaders.add , , "Note", 500
lv1.ListItems.Clear
Call call_which
End Sub
Private Sub call_which()
Dim combotxt As String
Dim i As Integer
combotxt = getword(Combo1.text, 1, " ")
If combotxt = "" Then Exit Sub
If combotxt <> last_chosen_var Then
lv1.ListItems.Clear
End If
last_chosen_var = combotxt
'*** If macro variable...
If LCase(Mid$(combotxt, 1, 1)) = "m" Then
For i = 3 To lv1.ColumnHeaders.count
lv1.ColumnHeaders(i).text = " "
lv1.ColumnHeaders.Item(i).Width = 0
Next
lv1.ColumnHeaders(2).text = "Value"
Call stat_ber_macro(combotxt)
Exit Sub
End If
For i = 2 To lv1.ColumnHeaders.count
lv1.ColumnHeaders.Item(i).Width = 600
Next
lv1.ColumnHeaders(2).text = "Mean"
lv1.ColumnHeaders(3).text = "Sum"
lv1.ColumnHeaders(4).text = "Std"
lv1.ColumnHeaders(5).text = "Min"
lv1.ColumnHeaders(6).text = "Max"
lv1.ColumnHeaders(7).text = "Count>0"
lv1.ColumnHeaders(8).text = "Atkin"
' lv1.ColumnHeaders(9).text = "Note"
Call prepare_temp(combotxt)
Call stat_ber(temp)
End Sub
Private Sub Form_Unload(Cancel As Integer)
coll_view.Remove Me.Tag
End Sub
Private Sub menuClear_Click()
lv1.ListItems.Clear
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 + vbCrLf
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()
If Text1.text = "Clear" Then
Call menuClear_Click
Exit Sub
End If
Call call_which
Call plotnew(0)
End Sub
Private Sub stat_ber(x)
Dim i As Long, medvärde As Long, n As Long, n_included As Long
Dim sum As Double, sum2 As Double, temp As Double, kvot As Double
Dim flag_notzero As Integer
flag_notzero = chkNotzero
If Mid$(Combo1.text, 1, 1) = "i" Then
n = m_icount
Else
n = m_hcount
End If
stat_summa = 0
stat_medel = 0
stat_std = 0
stat_min = 9.9E+100
stat_max = -9.9E+100
stat_antalmedvärde = 0
stat_atkinson = 0
sum = 0
medvärde = 0
For i = 1 To n
' Fasta priser om display_price_level=1
x(i) = x(i) * m_price99 ^ display_price_level
'*** Individual analysis
If (n = m_icount) Then
If select_i(i) = 1 Then
n_included = n_included + 1
sum = sum + x(i)
sum2 = sum2 + x(i) ^ 2
If x(i) > 0 Then medvärde = medvärde + 1
If x(i) < stat_min Then stat_min = x(i)
If x(i) > stat_max Then stat_max = x(i)
End If
End If
'*** Household analysis
If (n = m_hcount) Then
If select_h(i) = 1 Then
n_included = n_included + 1
sum = sum + x(i)
sum2 = sum2 + x(i) ^ 2
If x(i) > 0 Then medvärde = medvärde + 1
If x(i) < stat_min Then stat_min = x(i)
If x(i) > stat_max Then stat_max = x(i)
End If
End If
Next
stat_summa = sum
stat_medel = 0
If medvärde > 0 Then
If flag_notzero = 0 Then
stat_medel = sum / n_included
Else
stat_medel = sum / medvärde
End If
End If
stat_antalmedvärde = medvärde
If n_included > 1 Then
If (sum2 - (sum ^ 2) / n_included) / (n_included - 1) >= 0 Then
stat_std = Sqr((sum2 - (sum ^ 2) / n_included) / (n_included - 1))
Else
stat_std = 0
End If
Else
stat_std = 0
End If
If flag_notzero = 1 Then
If medvärde > 1 Then
If (sum2 - (sum ^ 2) / n_included) / (n_included - 1) >= 0 Then
stat_std = Sqr((sum2 - (sum ^ 2) / medvärde) / (medvärde - 1))
Else
stat_std = 0
End If
Else
stat_std = 0
End If
End If
' Atkinson
kvot = 0
temp = 0
For i = 1 To n
'*** Individual analysis
If n = m_icount Then
If select_i(i) = 1 And stat_medel > 0 Then
If x(i) >= 0 Then
If stat_medel > 0 Then
kvot = Sqr(x(i) / stat_medel)
End If
temp = temp + kvot
End If
End If
End If
'*** Individual analysis
If n = m_hcount Then
If select_h(i) = 1 And stat_medel > 0 Then
If x(i) >= 0 Then
If stat_medel > 0 Then
kvot = Sqr(x(i) / stat_medel)
End If
temp = temp + kvot
End If
End If
End If
Next
kvot = 0
If medvärde > 0 And n_included > 0 Then
If flag_notzero = 0 Then
kvot = temp / n_included
Else
kvot = temp / medvärde
End If
End If
kvot = kvot ^ 2
stat_atkinson = 1 - kvot
Dim m
Set m = lv1.ListItems.add()
m.text = CStr(base_year + model_time)
If stat_medel < 5 Then
m.SubItems(1) = round(stat_medel, 3)
Else
m.SubItems(1) = round(stat_medel, 1)
End If
If stat_summa * m_weight < 1000000# Then
lv1.ColumnHeaders.Item(3) = "Sum"
m.SubItems(2) = stat_summa * m_weight
Else
lv1.ColumnHeaders.Item(3) = "Sum milj"
m.SubItems(2) = round(stat_summa / 1000000# * m_weight, 1)
End If
If stat_std < 5 Then
m.SubItems(3) = round(stat_std, 3)
Else
m.SubItems(3) = round(stat_std, 1)
End If
If Abs(stat_min) < 5 Then
m.SubItems(4) = round(stat_min, 3)
Else
m.SubItems(4) = round(stat_min, 1)
End If
If stat_max < 5 Then
m.SubItems(5) = round(stat_max, 3)
Else
m.SubItems(5) = round(stat_max, 1)
End If
m.SubItems(6) = stat_antalmedvärde * m_weight
m.SubItems(7) = round(stat_atkinson, 3)
' m.SubItems(8) = exclude_txt
' Select last item
Dim nlist As Integer
nlist = lv1.ListItems.count
Set lv1.SelectedItem = lv1.ListItems(nlist)
Call delete_duplicate
Me.Caption = "Univ: " & Combo1.text
If display_price_level = 1 Then Me.Caption = "Univ1999: " & Combo1.text
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 lv1.ColumnHeaders.count - 1
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 = lv1.ColumnHeaders.count Then
lv1.ListItems.Remove (lv1.ListItems.count)
End If
End Sub
Public Sub stat_ber_macro(txt)
stat_medel = 0
Dim m
Set m = lv1.ListItems.add()
m.text = CStr(base_year + model_time)
stat_medel = get_macro_value(txt) * m_price99 ^ display_price_level
If stat_medel < 5 Then
m.SubItems(1) = round(stat_medel, 3)
Else
m.SubItems(1) = round(stat_medel, 1)
End If
m.SubItems(2) = ""
m.SubItems(3) = ""
m.SubItems(4) = ""
m.SubItems(5) = ""
m.SubItems(6) = ""
m.SubItems(7) = ""
' m.SubItems(8) = ""
' Select last item
Dim nlist As Integer
nlist = lv1.ListItems.count
Set lv1.SelectedItem = lv1.ListItems(nlist)
Call delete_duplicate
Me.Caption = "Univ: " & Combo1.text
If display_price_level = 1 Then Me.Caption = "Univ1999: " & Combo1.text
'controlcenter.chkSelection.Caption = exclude_txt
End Sub
' **********************************************
' Miniplot
' **********************************************
Private Sub lv1_ColumnClick(ByVal ColumnHeader As ComctlLib.ColumnHeader)
Dim i As Integer
For i = 1 To lv1.ColumnHeaders.count
If lv1.ColumnHeaders(i) = ColumnHeader Then Exit For
Next
If i > 1 Then
Call plotnew(i)
End If
End Sub
Private Sub plotnew(colnr As Integer)
Dim n As Integer, i As Integer
Dim y() As Double, miny As Double, maxy As Double
Static oldcolnr As Integer
' 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) = CDbl(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