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