VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form monitor_kernel
AutoRedraw = -1 'True
Caption = "Kernel"
ClientHeight = 2865
ClientLeft = 60
ClientTop = 345
ClientWidth = 6180
LinkTopic = "Form1"
MaxButton = 0 'False
MDIChild = -1 'True
ScaleHeight = 2865
ScaleWidth = 6180
Begin VB.CheckBox chkClearold
Caption = "Clear old"
Height = 195
Left = 4560
TabIndex = 5
ToolTipText = "Clear before redraw"
Top = 120
Value = 1 'Checked
Width = 975
End
Begin VB.CheckBox chkAutomax
Caption = "Auto max"
Height = 195
Left = 2040
TabIndex = 3
Top = 195
Value = 1 'Checked
Width = 975
End
Begin VB.CheckBox chkAutomin
Caption = "Auto min"
Height = 195
Left = 2040
TabIndex = 2
Top = 0
Value = 1 'Checked
Width = 975
End
Begin VB.CommandButton cmdParam
Caption = "->"
Height = 315
Left = 3120
TabIndex = 4
ToolTipText = "View options"
Top = 0
Width = 615
End
Begin ComctlLib.Slider Slider1
Height = 405
Left = 4500
TabIndex = 7
ToolTipText = "Increase/decrease points"
Top = 1380
Width = 1635
_ExtentX = 2884
_ExtentY = 714
_Version = 327682
Min = 1
Max = 100
SelStart = 50
TickFrequency = 10
Value = 50
End
Begin VB.ListBox slask1
Height = 2595
Left = 120
TabIndex = 10
Top = 3120
Width = 2475
End
Begin VB.TextBox Text1
Height = 315
Left = 5640
TabIndex = 0
TabStop = 0 'False
Top = 60
Width = 795
Visible = 0 'False
End
Begin VB.ComboBox Combo1
Height = 315
ItemData = "monitor_kernel.frx":0000
Left = 0
List = "monitor_kernel.frx":0002
Sorted = -1 'True
TabIndex = 1
ToolTipText = "Select variable"
Top = 0
Width = 1935
End
Begin ComctlLib.Slider Slider2
Height = 405
Left = 4440
TabIndex = 6
ToolTipText = "Increase/decrease bandwidth"
Top = 600
Width = 1695
_ExtentX = 2990
_ExtentY = 714
_Version = 327682
Max = 20
SelStart = 1
TickFrequency = 10
Value = 1
End
Begin VB.Image imgCalc
Height = 480
Left = 1380
Picture = "monitor_kernel.frx":0004
Top = 1320
Width = 480
Visible = 0 'False
End
Begin VB.Label lblbandwidth
Alignment = 1 'Right Justify
Height = 195
Left = 3900
TabIndex = 14
Top = 660
Width = 495
End
Begin VB.Line lineVert
X1 = 6540
X2 = 6540
Y1 = 2580
Y2 = 2340
End
Begin VB.Label lblAxis
BackStyle = 0 'Transparent
Height = 660
Left = 0
TabIndex = 13
Top = 2160
Width = 3795
End
Begin VB.Label lblmouse
Alignment = 1 'Right Justify
BackColor = &H00C0FFFF&
BorderStyle = 1 'Fixed Single
Height = 315
Left = 5040
TabIndex = 12
Top = 2220
Width = 1035
End
Begin VB.Label lblpoints
Alignment = 1 'Right Justify
Height = 195
Left = 3900
TabIndex = 11
Top = 1440
Width = 495
End
Begin VB.Label lblMax
Alignment = 1 'Right Justify
Height = 195
Left = 2700
TabIndex = 9
Top = 2570
Width = 735
End
Begin VB.Label lblMin
Height = 195
Left = 50
TabIndex = 8
Top = 2570
Width = 735
End
End
Attribute VB_Name = "monitor_kernel"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Option Base 1
Dim frekvens() As Double
Dim max As Double
Dim min As Double
Dim display_price_level As Integer 'At load only
Private Sub chkAutomax_Click()
If chkAutomax = 1 Then Call call_which
End Sub
Private Sub chkAutomin_Click()
If chkAutomin = 1 Then Call call_which
End Sub
Private Sub cmdParam_Click()
If Me.Width < 6300 Then
Me.Width = 6300
cmdParam.Caption = "<-"
Else
Me.Width = 3885
cmdParam.Caption = "->"
End If
End Sub
Public Sub Combo1_Click()
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 = "Kernel p1999"
End If
Me.Height = 3270
Me.Width = 3885
lblpoints.Caption = Slider1.value
lblbandwidth.Caption = Slider2.value
lblmouse.Visible = False
lineVert.Visible = False
Dim cv
For Each cv In var_coll
Combo1.AddItem cv
Next
Call call_which
End Sub
Private Sub call_which()
'If lv1.ListItems.count = 0 Then Exit Sub
If Combo1.text = "" Then Exit Sub
Call prepare_temp(Combo1.text)
Call stat_ker(temp)
End Sub
Private Sub lblAxis_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim xval As Double
xval = (x - 90) / (3500 - 90) * (max - min) + min
If Button = 1 Then
min = xval
chkAutomin = 0
End If
If Button = 2 Then
max = xval
chkAutomax = 0
End If
Call call_which
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
lblmouse.Caption = ""
lblmouse.Visible = False
lineVert.Visible = False
End Sub
Private Sub Form_Unload(Cancel As Integer)
coll_view.Remove Me.Tag
End Sub
Private Sub lblAxis_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim xval As Double
lineVert.x1 = x
lineVert.x2 = x
lineVert.y1 = 500
lineVert.y2 = 2500
lineVert.Visible = True
lineVert.Refresh
xval = (x - 90) / (3500 - 90) * (max - min) + min
'MsgBox xval
lblmouse.Caption = round(xval, 1)
' lblmouse.Caption = X & " " & Y
If x < 2500 Then
lblmouse.Left = x + 70
Else
lblmouse.Left = x - 1100
End If
lblmouse.Top = y + 2000 - 200
lblmouse.Visible = True
lblmouse.Refresh
End Sub
Private Sub Slider1_Change()
lblpoints.Caption = Slider1.value
lblpoints.Refresh
Call call_which
'MsgBox Slider1.value
End Sub
Private Sub Slider2_Change()
lblbandwidth.Caption = Slider2.value
lblbandwidth.Refresh
Call call_which
End Sub
Private Sub Text1_Change()
'Call stat_ber(i_age)
Call call_which
End Sub
Private Sub stat_ker(x)
Dim h As Double, punkter As Double, intervall As Double, uppl As Double
Dim punktnr As Integer, j As Integer, k As Integer
Dim i As Long, n As Long, z As Long
Dim zz As Double, tempmin As Double, tempmax As Double
Dim sel_vec()
' imgCalc.Visible = True
' imgCalc.Refresh
If Mid$(Combo1.text, 1, 1) = "i" Then
n = m_icount
ReDim sel_vec(1 To m_icount)
For i = 1 To m_icount
sel_vec(i) = i_selected(i)
Next
Else
n = m_hcount
ReDim sel_vec(1 To m_hcount)
For i = 1 To m_hcount
sel_vec(i) = h_selected(i)
Next
End If
'** Bandwidth **;
'h = 15
h = Slider2.value
'** Maximum value **;
' max = 100
'** Minimum value **;
' min = 0
If chkAutomin = 1 Or chkAutomax = 1 Then
tempmax = -9.9E+100
tempmin = 9.9E+100
For i = 1 To n
' Fasta priser om display_price_level=1
x(i) = x(i) * m_price99 ^ display_price_level
If sel_vec(i) = 1 Then
If x(i) > tempmax Then tempmax = x(i)
If x(i) < tempmin Then tempmin = x(i)
End If
Next
End If
If chkAutomin = 1 Then min = tempmin
If chkAutomax = 1 Then max = tempmax
' If autoscale = 1 Or min = max Or max < min Then
' max = -9.9E+100
' min = 9.9E+100
' For i = 1 To n
' If exclude_in_stat_compute(i) = 0 Then
' If x(i) > max Then max = x(i)
' If x(i) < min Then min = x(i)
' End If
' Next
' End If
If min = max Then
Line (xpix(0, 0, 1) - 45, ypix(0, 0, 1) + 45) _
-(xpix(1, 0, 1) + 45, ypix(1, 0, 1) - 45), QBColor(15), BF
Line (xpix(0, 0, 1), ypix(0, 0, 1)) _
-(xpix(1, 0, 1), ypix(0, 0, 1))
Line (xpix(0, 0, 1), ypix(0, 0, 1)) _
-(xpix(0, 0, 1), ypix(1, 0, 1))
' imgCalc.Visible = False
' imgCalc.Refresh
Me.Refresh
Exit Sub
End If
'** Antal ut-punkter**;
'punkter = 10
punkter = Slider1.value
'* Beräkna upplösning mm*;
intervall = max - min
uppl = Int(intervall / punkter)
uppl = maxi(1, uppl)
ReDim frekvens(0 To punkter)
For i = 1 To n
If sel_vec(i) = 1 Then
If x(i) >= min And x(i) <= max Then
' mittenvärde
punktnr = Int((x(i) - min) / intervall * punkter)
frekvens(punktnr) = frekvens(punktnr) + norm(0)
' antal punkter till vänster
k = 0
For j = punktnr - h To punktnr - 1
If j >= 0 Then frekvens(j) = frekvens(j) + norm(-1.5 + k / h * 1.5)
k = k + 1
Next
' antal punkter till höger
k = 0
For j = punktnr + h To punktnr + 1 Step -1
If j <= punkter Then frekvens(j) = frekvens(j) + norm(1.5 - k / h * 1.5)
k = k + 1
Next
End If
End If
Next
slask1.Clear
For z = 0 To punkter
slask1.AddItem round(frekvens(z), 1)
Next
' imgCalc.Visible = False
' imgCalc.Refresh
Me.Refresh
Call plotserie
lblMin.Caption = round(min, 1)
lblMax.Caption = round(max, 1)
End Sub
Private Function norm(x As Double) As Double
norm = 1# / Sqr(2# * 3.141592654) * Exp(-(x ^ 2# / 2#))
End Function
Public Sub plotserie()
Dim x() As Double, maxx As Double, minx As Double
Dim n As Integer, i As Integer
n = UBound(frekvens)
maxx = -999999999
If chkClearold = 1 Then
Line (xpix(0, 0, 1) - 45, ypix(0, 0, 1) + 45) _
-(xpix(1, 0, 1) + 45, ypix(1, 0, 1) - 45), QBColor(15), BF
Line (xpix(0, 0, 1), ypix(0, 0, 1)) _
-(xpix(1, 0, 1), ypix(0, 0, 1))
Line (xpix(0, 0, 1), ypix(0, 0, 1)) _
-(xpix(0, 0, 1), ypix(1, 0, 1))
End If
For i = 0 To n
If frekvens(i) > maxx Then maxx = frekvens(i)
Next
maxx = maxx * 1.05
Dim x0 As Double, y0 As Double, x1 As Double, y1 As Double
For i = 1 To n
x0 = xpix(i - 1, 0, CDbl(n))
y0 = ypix(frekvens(i - 1), 0, maxx)
x1 = xpix(i, 0, CDbl(n))
y1 = ypix(frekvens(i), 0, maxx)
Line (x0, y0)-(x1, y1), QBColor(0)
Next
End Sub
' **********************************************
' Funktion returnera pixelvärde för y
' **********************************************
Private Function ypix(y As Double, ymin As Double, ymax As Double) As Double
' relpos ett tal mellan 0 och 1
Dim relpos As Double
If Abs(ymax - ymin) < 0.000000000000001 Then
ypix = 800
Exit Function
End If
relpos = (y - ymin) / (ymax - ymin)
' ypix = 3800 - relpos * (3800 - 2160)
ypix = 2500 - relpos * (2500 - 500)
End Function
' **********************************************
' Funktion returnera pixelvärde för x
' **********************************************
Private Function xpix(x As Integer, xmin As Double, xmax As Double) As Double
' relpos ett tal mellan 0 och 1
Dim relpos As Double
If Abs(xmax - xmin) < 0.000000000000001 Then
xpix = 800
Exit Function
End If
relpos = (x - xmin) / (xmax - xmin)
xpix = 90 + relpos * (3500 - 90)
End Function
Static Function Log10(x)
Log10 = Log(x) / Log(10#)
End Function
'************************************************************************;
'************************************************************************;
'*** Kerneltp.sas 970822 TP ***;
'*** Rutin för normalfördelat kernel-estimat ***;
'*** ***;
'************************************************************************;
'************************************************************************;
'
'
'
'************************************************************************;
'************************************************************************;
'** PARAMETRAR **;
'************************************************************************;
'
'** Bandbredd **;
'%let h=15000;
'
'** Max-värde **;
'%let max=400000;
'
'** Min-värde **;
'%let min=0;
'
'** Antal ut-punkter**;
'%let punkt=300;
'
'** Indataset **;
'%let inds=r.dh97hh95;
'
'** Frekvensvariabel **;
'%let frekvar=cdisph/bkeh;
'
'** Viktvariabel **;
'%let vikt=bvikt;
'
'
'************************************************************************;
'************************************************************************;
'************************************************************************;
'************************************************************************;
'************************************************************************;
'************************************************************************;
'************************************************************************;
'************************************************************************;
'
'* Beräkna upplösning mm*;
'data _null_;
' nymax=&max-&min;
' call symput('_max',compress(nymax));
'run;
'
'
'data _null_;
' uppl=int(&_max/&punkt);
' uppl=max(1,uppl);
' call symput('uppl',uppl);
'run;
'
'
'
'
'data f;
' set &inds;
'
' * Analysvariabel *;
' frek=&frekvar;
'
' frek=frek-&min;
' if frek > 0;
'
'
' * Viktvariabel *;
' _bvikt=&vikt;
'
'
'keep _bvikt frek;
'run;
'
'
'
'
'data f2;
' set f end=slut;
' h=&h;
'
' array ff(%eval(&_max/&uppl)) _temporary_;
'
'
' do x=1 to %eval(&_max/&uppl);
' i=x*&uppl;
' arg=(i-frek)/h;
' ff(x) + (1/(sqrt(2*3.141592654)))*
' exp(-(arg**2/2))*_bvikt;
' end;
'
'
' if slut then do;
' do xx=1 to %eval(&_max/&uppl);
' x=xx*&uppl;
' fx=ff(xx);
' if fx=. then fx=0;
' output;
' end;
' end;
'keep x fx;
'run;
'
'data f2;
' set f2;
' x=x+&min;
'run;
'
'/*
'** Printa ut resultatet. **;
'** Resultatet kan överföras till Excel om man vill rita graf där **;
'proc print data=f2 noobs;
'run;
'
'** Följande ger en enkel SAS-graf **;
'symbol1 v=none i=join;
'proc gplot data=f2;
' plot fx*x;
'run;
'quit;
'*/
'
'data _null_;
' set f2;
' file 'test';
' put x fx;
'run;
'