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; '