Tweet
' First version presented: August 2001
'
' Re-updated version of a program previously presented in the forum.
'
' This version also runs using PB for Windows version 7. To avoid conflict
' with the new DIALOG FONT statement, the name of the font variable has been
' changed to Fontt&.
'
' June 24, 2002: Some graphics problems identified by Lance Edmonds have been
' dealt with - satisfactorily I hope. Many thanks for the invaluable feed-back
' from Lance and other members of the PB Forum.
'
' NB: Enhanced metafile dimensions adjusted January 16, 2004.
' P-values are also calculated now. Added January 18, 2004.
' January 21, 2004: Further corrections made to allow first
' data line of a read file to be data and not column headers.
'
' Original name:
'
' Linear regression and correlation for beginners like me.
' --------------------------------------------------------
'
' This program for PB for Windows 6 and 7 illustrates many useful techniques
' including: open and save files, combobox, listview, listbox as a simulated
' row header, textbox, label control for graphics, enhanced metafiles and
' copying of any produced text and graphics to the clipboard to be used
' instantly in other programs like word processors.
'
' Consider as an example a data base including height and weight for a number
' of individuals. You want to see to what extent weight is associated with
' or "correlated" with height. You can get an idea by plotting the set of
' data in co-ordinate system with height on the X-axis and weight on the
' Y-axis. It could be that the taller persons were also among the heaviest.
' To analyze this more closely you would perform a linear regression and
' correlation analysis.
'
' This analysis identifies the best fitting line (i.e. the regression
' line Y=a+b*X) to the sample of two dimensional points (X,Y) and determines
' how closely the points lie to that line. Thus the Y variable can be
' expressed in terms of a constant (a) and a slope (b) times the X variable.
' The constant is also referred to as the intercept, and the slope as the
' regression coefficient. The measure of the "closeness" of the points to
' the line is known at the correlation coefficient.
'
' You start by loading your data base which should be in Tab-separated text
' format without quotes. This file format can be specified in most spreadsheet
' and data base programs. You can also start by using the build-in default
' data base. The loaded data will be displayed in the listview box.
'
' Then you should select the Y-variable (the so-called dependent variable)
' from the upper combobox. Only numerical variables can be selected. Text
' variables are not being displayed in the combobox.
'
' Then you select the X-variable (the so-called independent variable) in the
' lower combobox.
'
' Now you can perform the analysis by pressing the button.
'
' The results of the calculation will be displayed in the textbox and the
' scatter plot with the regression line will be displayed in the graphic
' label control.
'
' You can edit and copy the text to the clipboard. The current graph can also
' be copied to the clipboard using the enhanced metafiles technique. If you
' copy the graph to a word processor you would even be able to edit the graph
' because of the enhanced metafiles format.
'
' For more information about the method you may consult any textbook on
' statistics.
' The initial code skeleton was generated by EZGUI Freeware Dialog Designer
' by Christopher R. Boss. See web site at EZGUI.COM. Unused code has
' been removed to improve clarity.
'
' The listview part was inspired by ideas and code provided to the
' PowerBasic FORUM by Peter Redei, David L Morris, Semen Matusovski,
' Jules Marchildon and Borje Hagsten.
'
' A label control is used as the graphics window. This was inspired
' by Forum notes by Lance Edmonds.
'
' Comments and suggestions are welcome
'
' Best Wishes,
' Erik Christensen, Copenhagen, Denmark. ---- [email protected]
[This message has been edited by Erik Christensen (edited January 23, 2004).]
'
' Re-updated version of a program previously presented in the forum.
'
' This version also runs using PB for Windows version 7. To avoid conflict
' with the new DIALOG FONT statement, the name of the font variable has been
' changed to Fontt&.
'
' June 24, 2002: Some graphics problems identified by Lance Edmonds have been
' dealt with - satisfactorily I hope. Many thanks for the invaluable feed-back
' from Lance and other members of the PB Forum.
'
' NB: Enhanced metafile dimensions adjusted January 16, 2004.
' P-values are also calculated now. Added January 18, 2004.
' January 21, 2004: Further corrections made to allow first
' data line of a read file to be data and not column headers.
'
' Original name:
'
' Linear regression and correlation for beginners like me.
' --------------------------------------------------------
'
' This program for PB for Windows 6 and 7 illustrates many useful techniques
' including: open and save files, combobox, listview, listbox as a simulated
' row header, textbox, label control for graphics, enhanced metafiles and
' copying of any produced text and graphics to the clipboard to be used
' instantly in other programs like word processors.
'
' Consider as an example a data base including height and weight for a number
' of individuals. You want to see to what extent weight is associated with
' or "correlated" with height. You can get an idea by plotting the set of
' data in co-ordinate system with height on the X-axis and weight on the
' Y-axis. It could be that the taller persons were also among the heaviest.
' To analyze this more closely you would perform a linear regression and
' correlation analysis.
'
' This analysis identifies the best fitting line (i.e. the regression
' line Y=a+b*X) to the sample of two dimensional points (X,Y) and determines
' how closely the points lie to that line. Thus the Y variable can be
' expressed in terms of a constant (a) and a slope (b) times the X variable.
' The constant is also referred to as the intercept, and the slope as the
' regression coefficient. The measure of the "closeness" of the points to
' the line is known at the correlation coefficient.
'
' You start by loading your data base which should be in Tab-separated text
' format without quotes. This file format can be specified in most spreadsheet
' and data base programs. You can also start by using the build-in default
' data base. The loaded data will be displayed in the listview box.
'
' Then you should select the Y-variable (the so-called dependent variable)
' from the upper combobox. Only numerical variables can be selected. Text
' variables are not being displayed in the combobox.
'
' Then you select the X-variable (the so-called independent variable) in the
' lower combobox.
'
' Now you can perform the analysis by pressing the button.
'
' The results of the calculation will be displayed in the textbox and the
' scatter plot with the regression line will be displayed in the graphic
' label control.
'
' You can edit and copy the text to the clipboard. The current graph can also
' be copied to the clipboard using the enhanced metafiles technique. If you
' copy the graph to a word processor you would even be able to edit the graph
' because of the enhanced metafiles format.
'
' For more information about the method you may consult any textbook on
' statistics.
' The initial code skeleton was generated by EZGUI Freeware Dialog Designer
' by Christopher R. Boss. See web site at EZGUI.COM. Unused code has
' been removed to improve clarity.
'
' The listview part was inspired by ideas and code provided to the
' PowerBasic FORUM by Peter Redei, David L Morris, Semen Matusovski,
' Jules Marchildon and Borje Hagsten.
'
' A label control is used as the graphics window. This was inspired
' by Forum notes by Lance Edmonds.
'
' Comments and suggestions are welcome
'
' Best Wishes,
' Erik Christensen, Copenhagen, Denmark. ---- [email protected]
Code:
#COMPILE EXE
#REGISTER NONE
#DIM ALL
#DEBUG ERROR ON
%NOANIMATE = 1
%NODRAGLIST = 1
%NOHEADER = 1
%NOIMAGELIST = 1
%NOSTATUSBAR = 1
%NOTABCONTROL = 1
%NOTOOLBAR = 1
%NOTOOLTIPS = 1
%NOTRACKBAR = 1
%NOTREEVIEW = 1
%NOUPDOWN = 1
#INCLUDE "win32api.inc" ' Must come first before other include files !
#INCLUDE "commctrl.inc" ' The Common Controls include file !
#INCLUDE "COMDLG32.INC"
' ----------------------------------------------------------
%Form1_FILE = 500
' ----------------------------------------------------------
%Form1_DEFAULT = 505
%Form1_OPENFILE = 510
%Form1_SAVEAS = 515
%Form1_SEPARATOR_520 = 520
%Form1_SAVE_CUR_GRAPH = 522
%Form1_SEPARATOR_524 = 524
%Form1_EXIT = 525
' ----------------------------------------------------------
%Form1_EDIT = 600
' ----------------------------------------------------------
%Form1_UNDO = 601
%Form1_SEPARATOR_602 = 602
%Form1_CUT = 603
%Form1_PASTE = 606
%Form1_SEPARATOR_604 = 604
%Form1_TEXTCOPY = 605
%Form1_GRAPHCOPY = 610
%Form1_SELECTALL = 615
' ----------------------------------------------------------
%Form1_HELP = 700
' ----------------------------------------------------------
%Form1_HELP1 = 705
%Form1_ABOUT = 710
%FORM1_LABELRESULTS = 100
%FORM1_LABELFORGRAPH = 102
%FORM1_GRAPHLABEL = 105
%FORM1_LABELROW = 110
%FORM1_LABELDATA = 112
%FORM1_LABELLOADDATA = 115
%FORM1_PROCEDUREFRAME = 117
%FORM1_LABELSELECTX = 120
%FORM1_LABELSELECTY = 125
%FORM1_TEXTRESULTS = 127
%FORM1_COMBOBOXY = 130
%FORM1_COMBOBOXX = 135
%FORM1_BUTTONDOANALYSIS = 140
%FORM1_BUTTONEXIT = 145
%FORM1_LISTVIEWBOX1 = 150
%FORM1_LISTBOXROWHEAD = 155
' --------------------------------------------------
DECLARE SUB ShowDialog_Form1(BYVAL hParent&)
DECLARE CALLBACK FUNCTION Form1_DLGPROC
' --------------------------------------------------
' ------------------------------------------------
DECLARE SUB Form1_DEFAULT_Select()
DECLARE SUB Form1_OPENFILE_Select()
DECLARE SUB Form1_SAVEAS_Select()
DECLARE SUB Form1_EXIT_Select()
DECLARE SUB Form1_TEXTCOPY_Select()
DECLARE SUB Form1_GRAPHCOPY_Select()
DECLARE SUB Form1_HELP1_Select()
DECLARE SUB Form1_ABOUT_Select()
DECLARE CALLBACK FUNCTION CBF_FORM1_COMBOBOXY()
DECLARE CALLBACK FUNCTION CBF_FORM1_COMBOBOXX()
DECLARE CALLBACK FUNCTION CBF_FORM1_BUTTONDOANALYSIS()
DECLARE CALLBACK FUNCTION CBF_FORM1_BUTTONEXIT()
'
DECLARE FUNCTION MakeFont(BYVAL FontTypeSize AS LONG,BYVAL FontWeight AS LONG, _
BYVAL Italic AS LONG, BYVAL Underline AS LONG,BYVAL StrikeOut AS LONG, _
BYVAL FaceName AS STRING) AS LONG
DECLARE FUNCTION FilNameOpen() AS LONG
DECLARE FUNCTION FilNameSave() AS LONG
DECLARE FUNCTION FilNameSaveEMF() AS LONG
DECLARE FUNCTION FilePath(BYVAL Src AS STRING) AS STRING
DECLARE FUNCTION FileNam(BYVAL Src AS STRING) AS STRING
DECLARE SUB MATINVSIM (BYREF X() AS DOUBLE, BYVAL M AS LONG, BYREF DET AS DOUBLE, BYREF A() AS DOUBLE, BYREF Y() AS DOUBLE)
DECLARE SUB PrepareAndMakeGraph (BYVAL hDC AS LONG,BYVAL NV AS LONG,BYVAL NP AS LONG,BYVAL Xmax AS SINGLE, _
BYVAL Xmin AS SINGLE,BYVAL Ymax AS SINGLE,BYVAL Ymin AS SINGLE,BYVAL IIX AS LONG, _
BYVAL IIY AS LONG,BYREF NumDat() AS SINGLE,BYVAL Xtxt$,BYVAL Ytxt$)
DECLARE SUB FindAxisDimAndScale (BYVAL MaxVal AS SINGLE,BYVAL MinVal AS SINGLE,BYREF Start AS SINGLE,BYREF StepSize AS SINGLE,BYREF Labels AS LONG)
DECLARE SUB MakeXandYaxisWithText (BYVAL hDC AS LONG,BYVAL LeMarg AS SINGLE,BYVAL LoMarg AS SINGLE,BYVAL RiMarg AS SINGLE,BYVAL UpMarg AS SINGLE, _
BYVAL Xlow AS SINGLE,BYVAL Xstep AS SINGLE,BYVAL Xhigh AS SINGLE,BYVAL Ylow AS SINGLE,BYVAL Ystep AS SINGLE, _
BYVAL Yhigh AS SINGLE,BYVAL XConvFac AS SINGLE,BYVAL YConvFac AS SINGLE, BYVAL Xtxt$, _
BYVAL Ytxt$,BYVAL IPAT AS LONG)
DECLARE FUNCTION gColor(BYVAL I AS LONG) AS LONG
DECLARE FUNCTION PenStyle(BYVAL I AS LONG) AS LONG
' *************************************************************
GLOBAL hForm1& ' Dialog handle
' Global Handles for menus
GLOBAL hForm1_Menu0&
GLOBAL hForm1_Menu1&
GLOBAL hForm1_Menu2&
GLOBAL hForm1_Menu3&
GLOBAL hGraph AS LONG ' Handle for graphics window - a label (or static) control
'
GLOBAL Brush&
GLOBAL PAFU AS STRING ' path and file for input
GLOBAL PAFUout AS STRING ' path and file for output
GLOBAL PAFUemf AS STRING ' path and file for enhanced metafile format graph
GLOBAL DAT() AS STRING ' ARRAY TO HOLD THE DATA in listbox 1
GLOBAL head() AS STRING ' array to hold the headers in listbox 1
GLOBAL MaxLen() AS INTEGER ' (1:Columns)
GLOBAL AlphNum() AS INTEGER ' (1:Columns)
GLOBAL Rows AS LONG ' number of rows in array
GLOBAL Columns AS LONG ' number of columns in array
GLOBAL RowsNew AS LONG ' number of rows with complete X,Y values in a given analysis
GLOBAL HorizBaseU AS LONG
GLOBAL VertBaseU AS LONG
GLOBAL Delim AS STRING ' Delimiter for saving and loading files
' Set to $TAB (=CHR$(9)) in this program.
' You may change this.
GLOBAL COMBOBOXX_List() AS STRING
GLOBAL COMBOBOXY_List() AS STRING
GLOBAL LISTBOXROWHEAD_list() AS STRING
GLOBAL lfFont AS lOGFONT ' Logfont structure
GLOBAL LogPixelsY AS LONG 'pixels per inch of screen height
GLOBAL LogPixelsX AS LONG 'pixels per inch of screen width
GLOBAL AnalysisNumber AS LONG
GLOBAL T$
GLOBAL NumDat() AS SINGLE ' numerical data array
GLOBAL Xmax AS SINGLE, Xmin AS SINGLE, Ymax AS SINGLE, Ymin AS SINGLE
GLOBAL PowerX AS SINGLE, PowerY AS SINGLE
GLOBAL Xvar&,Yvar&
GLOBAL GRAFFLAG AS LONG
GLOBAL XDialUn&,YDialUn&,XPixMax&,YPixMax&
GLOBAL Rct AS RECT
GLOBAL Ps AS PAINTSTRUCT ' Paint structure
GLOBAL Xfact AS SINGLE, Yfact AS SINGLE
GLOBAL lpSize AS SIZEL
GLOBAL Constant AS DOUBLE,Coeff AS DOUBLE
GLOBAL RowHeadCorrect AS LONG
'
' *************************************************************
'
FUNCTION PBMAIN
LOCAL Count&
LOCAL hDC AS LONG
LOCAL CC1 AS INIT_COMMON_CONTROLSEX
CC1.dwSize=SIZEOF(CC1)
CC1.dwICC=%ICC_WIN95_CLASSES
InitCommonControlsEX CC1
Brush&=CreateSolidBrush(RGB(255,255,255)) ' white
'Retrieves a handle of a display device context (DC) for the
'client area of the specified window (here the desktop).
hDC = GetDC(%HWND_DESKTOP)
'
'Retrieves device-specific information about the number
'of pixels per logical inch along the screen height
'(depends on screen resolution setting).
'This is important to define appropriate font sizes.
LogPixelsY = GetDeviceCaps(hDC, %LOGPIXELSY)
LogPixelsX = GetDeviceCaps(hDC, %LOGPIXELSX)
'
ReleaseDC %HWND_DESKTOP, hDC
ShowDialog_Form1 0
DO
DIALOG DOEVENTS TO Count&
LOOP UNTIL Count&=0
DeleteObject Brush&
END FUNCTION
'
' Application Dialogs
' *************************************************************
SUB ShowDialog_Form1(BYVAL hParent&)
LOCAL Style&, ExStyle& ,hCtl&
LOCAL ComboStyle&, LabelStyle&,LabelStyle2&
LOCAL N&, CT&, r&, Fontt&,res&
LOCAL hListView AS LONG
LOCAL lStyle AS LONG
LOCAL result AS LONG
' hParent& = 0 if no parent Dialog
Style& = %WS_POPUP OR %DS_MODALFRAME OR %WS_CAPTION OR %WS_MINIMIZEBOX OR %WS_SYSMENU OR %DS_CENTER OR %WS_CLIPCHILDREN
' NB: the clipchildren style must be included
ExStyle& = 0
DIALOG NEW hParent&, "Linear Regression Analysis", 0, 0, 392, 260, Style&, ExStyle& TO hForm1&
LabelStyle& = %WS_CHILD OR %WS_VISIBLE OR %SS_CENTER
XDialUn&=168:YDialUn&=130
DIALOG UNITS hForm1&, XDialUn&, YDialUn& TO PIXELS XPixMax&, YPixMax&
Xfact=XPixMax&/XDialUn&: Yfact=YPixMax&/YDialUn& ' conversion factors from dialog units to pixels
' The graphics routines use pixels. Hence this conversion.
LabelStyle2& = %WS_CHILD OR %WS_VISIBLE OR %SS_GRAYFRAME OR %SS_LEFT
' NB: The grayframe style must be included
CONTROL ADD LABEL, hForm1&, %FORM1_GRAPHLABEL, "", 220, 9, XDialUn&,YDialUn&, LabelStyle2& ',%WS_EX_CLIENTEDGE
CONTROL HANDLE hForm1&, %FORM1_GRAPHLABEL TO hGraph ' handle for graphics window
' ---------------------------
MENU NEW BAR TO hForm1_Menu0&
' ---------------------------
MENU NEW POPUP TO hForm1_Menu1&
MENU ADD POPUP, hForm1_Menu0& ,"&File", hForm1_Menu1&, %MF_ENABLED
' - - - - - - - - - - - - - -
MENU ADD STRING, hForm1_Menu1&, "Use &Default data", %Form1_DEFAULT, %MF_ENABLED
MENU ADD STRING, hForm1_Menu1&, "&Open Data File", %Form1_OPENFILE, %MF_ENABLED
MENU ADD STRING, hForm1_Menu1&, "Save Data File &As", %Form1_SAVEAS, %MF_GRAYED
MENU ADD STRING, hForm1_Menu1&, "-", %Form1_SEPARATOR_520, %MF_ENABLED
MENU ADD STRING, hForm1_Menu1&, "Save Current &Graph", %Form1_SAVE_CUR_GRAPH, %MF_GRAYED
MENU ADD STRING, hForm1_Menu1&, "-", %Form1_SEPARATOR_524, %MF_ENABLED
MENU ADD STRING, hForm1_Menu1&, "E&xit", %Form1_EXIT, %MF_ENABLED
MENU NEW POPUP TO hForm1_Menu2&
MENU ADD POPUP, hForm1_Menu0& ,"&Edit", hForm1_Menu2&, %MF_ENABLED
' - - - - - - - - - - - - - -
MENU ADD STRING, hForm1_Menu2&, "&Undo", %Form1_UNDO, %MF_ENABLED
MENU ADD STRING, hForm1_Menu2&, "-", %Form1_SEPARATOR_602, %MF_ENABLED
MENU ADD STRING, hForm1_Menu2&, "Cu&t Selected Text to Clipboard", %Form1_CUT, %MF_ENABLED
MENU ADD STRING, hForm1_Menu2&, "&Paste text from Clipboard", %Form1_PASTE, %MF_ENABLED
MENU ADD STRING, hForm1_Menu2&, "&Copy Selected Text to Clipboard", %Form1_TEXTCOPY, %MF_ENABLED
MENU ADD STRING, hForm1_Menu2&, "Select &All Text", %Form1_SELECTALL, %MF_ENABLED
MENU ADD STRING, hForm1_Menu2&, "-", %Form1_SEPARATOR_604, %MF_ENABLED
MENU ADD STRING, hForm1_Menu2&, "Copy Present &Graph to Clipboard", %Form1_GRAPHCOPY, %MF_GRAYED
MENU NEW POPUP TO hForm1_Menu3&
MENU ADD POPUP, hForm1_Menu0& ,"&Help", hForm1_Menu3&, %MF_ENABLED
' - - - - - - - - - - - - - -
MENU ADD STRING, hForm1_Menu3&, "&Description of program", %Form1_HELP1, %MF_ENABLED
MENU ADD STRING, hForm1_Menu3&, "&About", %Form1_ABOUT, %MF_ENABLED
MENU ATTACH hForm1_Menu0&, hForm1&
CONTROL ADD LABEL, hForm1&, %FORM1_LABELFORGRAPH, "Regression Plot:", 234, 0, 142, 8, LabelStyle&
CONTROL ADD LABEL, hForm1&, %FORM1_LABELROW, "Row:", 4, 10, 20, 8, LabelStyle&
CONTROL ADD LABEL, hForm1&, %FORM1_LABELSELECTX, "3. Select Independent Variable ( X )", 257, 183, 124, 10, LabelStyle&
CONTROL ADD LABEL, hForm1&, %FORM1_LABELDATA, "Data to be analyzed:", 25, 0, 180, 8, LabelStyle&
CONTROL ADD LABEL, hForm1&, %FORM1_LABELSELECTY, "2. Select Dependent Variable ( Y )", 259, 158, 122, 10, LabelStyle&
CONTROL ADD LABEL, hForm1&, %FORM1_LABELLOADDATA, "1. Load Data", 259, 147, 122, 10, LabelStyle&
CONTROL ADD LABEL, hForm1&, %FORM1_LABELRESULTS, "Results:", 41, 136, 150, 8, LabelStyle&
' - - - - - - - - - - - - - - - - - - - - - - - - -
CONTROL ADD "Button", hForm1&, %FORM1_BUTTONDOANALYSIS, "4. Do Linear &Regression Analysis", 259, 210, 124, 12, _
%WS_CHILD OR %WS_VISIBLE OR %WS_DISABLED OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_FORM1_BUTTONDOANALYSIS
CONTROL ADD "Button", hForm1&, %FORM1_BUTTONEXIT, "E&xit", 259, 228, 124, 12, _
%WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_FORM1_BUTTONEXIT
CONTROL ADD TEXTBOX, hForm1&, %FORM1_TEXTRESULTS, "", 2, 144, 245, 101, _
%WS_CHILD OR %WS_VISIBLE OR %ES_MULTILINE OR %ES_WANTRETURN OR _
%ES_LEFT OR %WS_VSCROLL OR %ES_NOHIDESEL OR %ES_AUTOVSCROLL OR %WS_TABSTOP, _
%WS_EX_CLIENTEDGE
' an attempt to accomodate both large and small Windows font setting
IF Xfact>1.75 THEN ' large font
Fontt&=MakeFont(8,400,0,0,0,"Arial")
RowHeadCorrect = 0
ELSE ' small font
Fontt&=MakeFont(7,400,0,0,0,"Arial")
RowHeadCorrect = 2
END IF
CONTROL SEND hForm1&, %FORM1_TEXTRESULTS, %WM_SETFONT, Fontt&, %TRUE
' - - - - - - - - - - - - - - - - - - - - - - - - -
CONTROL ADD "SysListView32", hForm1&, %FORM1_LISTVIEWBOX1,"",26, 8, 190, 126+RowHeadCorrect, _
%WS_border OR %WS_Child OR %WS_TABSTOP OR %LVS_Report , %WS_EX_CLIENTEDGE
CONTROL HANDLE hForm1&,%FORM1_LISTVIEWBOX1 TO hListView
lStyle = SendMessage(hListView, _
%LVM_GETEXTENDEDLISTVIEWSTYLE, 0, 0)
lStyle = lStyle OR %LVS_EX_GRIDLINES
CALL SendMessage(hListView, %LVM_SETEXTENDEDLISTVIEWSTYLE, _
0, BYVAL lStyle)
r& = ShowWindow(hListView,%SW_SHOW)
result = GetDialogBaseUnits
'Horizontal dialog box base unit
'This is equal to the average width, in pixels, of the characters
'in the system font.
HorizBaseU = LOWRD(result)
'Vertical dialog box base unit
'This is equal to the height, in pixels, of the font.
VertBaseU = HIWRD(result)
' - - - - - - - - - - - - - - - - - - - - - - - - -
CONTROL ADD LISTBOX, hForm1&, %FORM1_LISTBOXROWHEAD, LISTBOXROWHEAD_List(), 2, 19+RowHeadCorrect, 24, 114, _
%WS_CHILD OR %WS_VISIBLE OR %LBS_NOTIFY OR %LBS_NOINTEGRALHEIGHT, _
%WS_EX_CLIENTEDGE
' The font below gives the same vertical spacing as in the listview box
' The left listbox works as a simulated row header which scrolls
' in parallel with the listview box
'
' An attempt to accomodate both large and small Windows font setting
IF Xfact>1.75 THEN ' large font
Fontt&=MakeFont(9,300,0,1,0,"Arial")
ELSE ' small font
Fontt&=MakeFont(8,300,0,1,0,"Arial")
END IF
CONTROL SEND hForm1&, %FORM1_LISTBOXROWHEAD, %WM_SETFONT, Fontt&, %TRUE
ComboStyle&=%WS_CHILD OR %WS_VISIBLE OR %CBS_DROPDOWNLIST OR %WS_VSCROLL OR %CBS_NOINTEGRALHEIGHT OR %WS_TABSTOP
CONTROL ADD COMBOBOX, hForm1&, %FORM1_COMBOBOXY, COMBOBOXY_List(), 259, 167, 124, 48, ComboStyle& CALL CBF_FORM1_COMBOBOXY
CONTROL ADD COMBOBOX, hForm1&, %FORM1_COMBOBOXX, COMBOBOXX_List(), 259, 192, 124, 48, ComboStyle& CALL CBF_FORM1_COMBOBOXX
CONTROL SET FOCUS hForm1&, %FORM1_TEXTRESULTS
CONTROL SEND hForm1&, %FORM1_TEXTRESULTS,%EM_SETSEL,0,-1
' Get co-ordinates for graphics label window rectangle
GetClientRect hGraph,Rct
DIALOG SHOW MODELESS hForm1& , CALL Form1_DLGPROC
END SUB
' ---------------------------------------------------------
CALLBACK FUNCTION Form1_DLGPROC
LOCAL hemf AS LONG,lpszFile AS ASCIIZ*80
LOCAL hdcEMF AS LONG
LOCAL hDC AS LONG
LOCAL hCtl AS LONG,hEdit AS LONG
LOCAL lpStart AS LONG, lpEnd AS LONG
LOCAL res AS LONG
STATIC GrafCopyFlag AS LONG
STATIC TopLV AS LONG
STATIC TopRH AS LONG
CONTROL HANDLE hForm1&,%FORM1_TEXTRESULTS TO hEdit
' Get first and last position of the selection if any
SendMessage hEdit, %EM_GETSEL, VARPTR(lpStart), VARPTR(lpEnd)
IF lpStart=lpEnd THEN ' No text selection. Disable cut and copy
EnableMenuItem hForm1_Menu2&, %Form1_CUT, %MF_BYCOMMAND OR %MF_GRAYED
EnableMenuItem hForm1_Menu2&, %Form1_TEXTCOPY, %MF_BYCOMMAND OR %MF_GRAYED
ELSE ' Text selection. Enable cut and copy
EnableMenuItem hForm1_Menu2&, %Form1_CUT, %MF_BYCOMMAND OR %MF_ENABLED
EnableMenuItem hForm1_Menu2&, %Form1_TEXTCOPY, %MF_BYCOMMAND OR %MF_ENABLED
END IF
IF SendMessage (hEdit, %EM_CANUNDO, 0, 0) THEN ' Undo valid
EnableMenuItem hForm1_Menu2&, %Form1_UNDO, %MF_BYCOMMAND OR %MF_ENABLED
ELSE ' Undo not valid
EnableMenuItem hForm1_Menu2&, %Form1_UNDO, %MF_BYCOMMAND OR %MF_GRAYED
END IF
SELECT CASE CBMSG
' Common Windows Messages you may want to process
' -----------------------------------------------
' these two lines are due to feedback from Borje Hagsten
CASE %WM_NCACTIVATE
IF CBWPARAM THEN CONTROL SET FOCUS CBHNDL, %FORM1_TEXTRESULTS
CASE %WM_PAINT
BeginPaint CBHNDL, Ps
IF GRAFFLAG=10 THEN ' graph can be made
'
' SPECIFY RECTANCLE IN 0.01 MM UNITS FOR CREATION OF METAFILE:
LOCAL hdcRef&,iWidthMM&,iHeightMM&,iWidthPels&,iHeightPels&
'
' Obtain a handle to a reference device context.
hdcRef = GetDC(CBHNDL)
'
' Determine the picture frame dimensions.
' iWidthMM is the display width in millimeters.
' iHeightMM is the display height in millimeters.
' iWidthPels is the display width in pixels.
' iHeightPels is the display height in pixels
iWidthMM = GetDeviceCaps(hdcRef, %HORZSIZE)
iHeightMM = GetDeviceCaps(hdcRef, %VERTSIZE)
iWidthPels = GetDeviceCaps(hdcRef, %HORZRES)
iHeightPels = GetDeviceCaps(hdcRef, %VERTRES)
ReleaseDC CBHNDL, hdcRef
' Retrieve the coordinates of the client
' rectangle, in pixels.
GetClientRect hGraph,Rct
' Convert client coordinates to .01-mm units.
' Use iWidthMM, iWidthPels, iHeightMM, and
' iHeightPels to determine the number of
' .01-millimeter units per pixel in the x-
' and y-directions.
Rct.nLeft = (Rct.nLeft * iWidthMM * 100)/iWidthPels
Rct.nTop = (Rct.nTop * iHeightMM * 100)/iHeightPels
Rct.nRight = (Rct.nRight * iWidthMM * 100)/iWidthPels
Rct.nBottom = (Rct.nBottom * iHeightMM * 100)/iHeightPels
hdcEMF = CreateEnhMetafile (%NULL, BYVAL %NULL, Rct, BYVAL %NULL) ' Rct
' Get rectangle in pixels to display diagram
GetClientRect hGraph,Rct
CALL PrepareAndMakeGraph (hdcEMF,2, Rows, Xmax, Xmin, Ymax, Ymin, 1, 2, NumDat(), head(Xvar&), head(Yvar&))
hemf = CloseEnhMetafile (hdcEMF) ' get handle to enhanced metafile
' Handle to label where the diagram is to be drawn
hDC = GetDC(GetDlgItem(CBHNDL, %FORM1_GRAPHLABEL))
CALL PlayEnhMetafile (hDC, hemf, Rct)
' "plays" the metafile in the label window,
' i.e. the graphics procedures are now being performed in
' that window.
EnableMenuItem hForm1_Menu1&,%Form1_SAVE_CUR_GRAPH, %MF_BYCOMMAND OR %MF_ENABLED
IF GrafCopyFlag=5 THEN
lpszFile = PAFUemf
Res& = CopyEnhMetaFile(hemf,lpszFile)
GrafCopyFlag=0
END IF
IF GrafCopyFlag=3 THEN ' copy graphic enhanced metafile to clipboard
' This code is due to Peter Stephensen:
%CF_ENHMETAFILE = 14
IF OpenClipboard(%NULL) THEN
EmptyClipboard
SetClipboardData %CF_ENHMETAFILE, hemf
CloseClipboard
END IF
GrafCopyFlag=0
END IF
ELSE
hDC = GetDC(GetDlgItem(CBHNDL, %FORM1_GRAPHLABEL))
res&=FillRect (hDC, Rct, GetStockObject(%WHITE_BRUSH))
END IF
EndPaint CBHNDL, Ps
ReleaseDC GetDlgItem(CBHNDL,%FORM1_GRAPHLABEL), hDC
FUNCTION = 1
' -----------------------------------------------
CASE %WM_CTLCOLORMSGBOX , %WM_CTLCOLORBTN, %WM_CTLCOLOREDIT,_
%WM_CTLCOLORSTATIC, %WM_CTLCOLORSCROLLBAR, %WM_CTLCOLORLISTBOX
' Control colors
SELECT CASE GetDlgCtrlID(CBLPARAM)
CASE %FORM1_LISTBOXROWHEAD
SetTextColor CBWPARAM, RGB(145,145,145)
SetBkColor CBWPARAM, RGB(255,255,255)
FUNCTION=Brush&
CASE ELSE
FUNCTION=0
END SELECT
CASE %WM_NOTIFY
' This code ensures parallel scrolling of the "Row header"
' This idea behind this code was Borje Hagsten's
CONTROL SEND hForm1&,%FORM1_LISTVIEWBOX1,%LVM_GETTOPINDEX,0,0 TO TopLV
IF TopLV<>TopRH THEN
CONTROL SEND hForm1&,%FORM1_LISTBOXROWHEAD,%LB_SETTOPINDEX,TopLV,0
TopRH=TopLV
END IF
CASE %WM_COMMAND
' Process Messages to Controls that have no Callback Function
' and Process Messages to Menu Items
SELECT CASE CBCTL
CASE %Form1_DEFAULT
Form1_DEFAULT_Select
CASE %Form1_OPENFILE
Form1_OPENFILE_Select
CASE %Form1_SAVEAS
Form1_SAVEAS_Select
CASE %Form1_SAVE_CUR_GRAPH
IF FilNameSaveEMF() THEN
END IF
' The following causes the metafile to be saved on disk.
GrafCopyFlag=5 ' see CASE %WM_PAINT above
res&=InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
CASE %Form1_EXIT
Form1_EXIT_Select
CASE %Form1_UNDO
'Send a WM_UNDO message to the edit control to
'undo the last operation. When this message is
'sent to the edit control, the previously deleted
'text is restored or the previously added text
'is deleted.
SendMessage hEdit, %EM_UNDO, 0, 0
CASE %Form1_CUT
'Send a %WM_CUT message to the edit control to
'delete (cut) the current selection, if any, in
'the edit control and copy the deleted text to
'the clipboard in CF_TEXT format.
SendMessage hEdit, %WM_CUT, 0, 0
CASE %Form1_PASTE
'Sends a %WM_PASTE message to the edit control to
'copy the current content of the clipboard to
'the edit control at the current caret position.
'Data is inserted only if the clipboard contains
'data in CF_TEXT format.
SendMessage hEdit, %WM_PASTE, %CF_TEXT, 0
CASE %Form1_TEXTCOPY
'Send a %WM_COPY message to the edit control to
'copy the current selection to the clipboard
'in CF_TEXT format.
SendMessage hEdit, %WM_COPY, 0, 0
CASE %Form1_GRAPHCOPY
' The following causes the metafile to be copied to the clipboard.
GrafCopyFlag=3 ' see CASE %WM_PAINT above
res&=InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
CASE %Form1_SELECTALL
'Send an %EM_SETSEL message to select a range of
'characters in the edit control.
'If the nStart parameter is 0 and the nEnd
'parameter is -1, all the text in the edit
'control is selected.
SendMessage hEdit, %EM_SETSEL,0,-1
CASE %Form1_HELP1
Form1_HELP1_Select
CASE %Form1_ABOUT
Form1_ABOUT_Select
CASE ELSE
END SELECT
CASE ELSE
END SELECT
END FUNCTION
' ------------------------------------------------
SUB Form1_DEFAULT_Select()
LOCAL I&,J&,FL&,Y&
LOCAL PI2 AS DOUBLE
PI2 = ATN(1) * 8 ' two PI
' Make default test data set.
DATA "Initials","Weight (kg)","Height (cm)","Body Mass Index (BMI)","Hemoglobin (mmol/l)","Glucose (mmol/l)","ALT (IU/l)","Systolic Blood Pressure (mm Hg)","Diastolic Blood Pressure (mm Hg)"
Columns=9 ' number of columns
Rows=300 ' number of rows
REDIM head(1:Rows)
REDIM DAT(1:Columns,1:Rows)
FOR I&=1 TO Columns
head(I&)=READ$(I&)
NEXT
RANDOMIZE 1.5 ' The same seed ensures same data set each time you selects default data
'
'This function is used to create random values having a normal distribution
'with a specified Mean and Standard Deviation (SD):
'X = SQR(-2*LOG(RND))*COS(PI2*RND)*Standard_Deviation+Mean
'
FOR I&=1 TO Rows
DAT(1,I&)=CHR$(RND(65,90))+". "+CHR$(RND(65,90))+". "+CHR$(RND(65,90))+"."
DAT(2,I&)=LTRIM$(STR$(ROUND(SQR(-2*LOG(RND))*COS(PI2*RND)*17+84,1)))
DAT(3,I&)=LTRIM$(STR$(ROUND(SQR(-2*LOG(RND))*COS(PI2*RND)*18+182,1)))
DAT(4,I&)=LTRIM$(STR$(ROUND(VAL(DAT(2,I&))*10000/VAL(DAT(3,I&))^2,1)))
DAT(5,I&)=LTRIM$(STR$(RND(38,80)/10+ROUND(VAL(DAT(4,I&)),0)/10))
DAT(6,I&)=LTRIM$(STR$(RND(19,70)/10+ROUND(VAL(DAT(4,I&)),0)/10))
DAT(7,I&)=LTRIM$(STR$(ROUND(RND(-41,20)/3+VAL(DAT(4,I&))*2.1,0)))
DAT(8,I&)=LTRIM$(STR$(ROUND(RND(95,160)+VAL(DAT(4,I&)),0)))
DAT(9,I&)=LTRIM$(STR$(ROUND(RND(45,80)+VAL(DAT(4,I&)),0)))
NEXT
CALL CheckAndDisplayData()
MSGBOX "This random data base is artificial and any similarity to any known person is completely accidental !",%MB_ICONINFORMATION,"Random default data"
EnableMenuItem hForm1_Menu1&, %Form1_SAVEAS, %MF_BYCOMMAND OR %MF_ENABLED
END SUB
' ------------------------------------------------
SUB Form1_OPENFILE_Select()
IF FilNameOpen() THEN
IF Rows>=2 THEN
CALL CheckAndDisplayData()
EnableMenuItem hForm1_Menu1&, %Form1_SAVEAS, %MF_BYCOMMAND OR %MF_ENABLED
END IF
END IF
END SUB
' ------------------------------------------------
SUB Form1_SAVEAS_Select()
IF FilNameSave() THEN
END IF
END SUB
' ------------------------------------------------
SUB Form1_EXIT_Select()
LOCAL res&
res&=MSGBOX ("Are you sure?",%MB_YESNO OR %MB_ICONQUESTION ,"End?")
IF res&=%IDYES THEN DIALOG END hForm1&
END SUB
' ------------------------------------------------
SUB Form1_HELP1_Select()
LOCAL St AS STRING
St="Consider as an example a data base including height and weight for a number "+ _
"of individuals. You want to see to what extent weight is associated with "+ _
"or ""correlated"" with height. You can get an idea by plotting the set of "+ _
"data in co-ordinate system with height on the X-axis and weight on the "+ _
"Y-axis. It could be that the taller persons were also among the heaviest. "+ _
"To analyze this more closely you would perform a linear regression and "+ _
"correlation analysis."+$CRLF+ _
" This analysis identifies the best fitting line (i.e. the regression "+ _
"line Y=a+b*X) to the sample of two dimensional points (X,Y) and determines "+ _
"how closely the points lie to that line. Thus the Y variable can be "+ _
"expressed in terms of a constant (a) and a slope (b) times the X variable. "+ _
"The constant is also referred to as the intercept, and the slope as the "+ _
"regression coefficient. The measure of the ""closeness"" of the points to "+ _
"the line is known at the correlation coefficient. "+$CRLF+ _
" First you load your data base which should be in Tab-separated text "+ _
"format without quotes. This file format can be specified in most spreadsheet "+ _
"and data base programs. You can also start by using the build-in default "+ _
"data base. The loaded data will be displayed in the listview box."+$CRLF+ _
" Second you should select the Y-variable (the so-called dependent variable) "+ _
"from the upper combobox. Only numerical variables can be selected. Text "+ _
"variables are not being displayed in the combobox."+$CRLF+ _
" Third you select the X-variable (the so-called independent variable) in the "+ _
"lower combobox."+$CRLF+ _
" Fourth you perform the analysis by pressing the button."+$CRLF+ _
" The results of the calculation will be displayed in the textbox and the "+ _
"scatter plot with the regression line will be displayed in the graphic "+ _
"label control."+$CRLF+ _
" You can edit and copy the text to the clipboard. The current graph can also "+ _
"be copied to the clipboard using the enhanced metafiles technique. If you "+ _
"copy the graph to a word processor you would even be able to edit the graph "+ _
"because of the enhanced metafiles format."+$CRLF+ _
" For more information about the method you may consult any textbook on "+ _
"statistics."+$CRLF+$CRLF+" Best wishes Erik Christensen"
MSGBOX St,%MB_ICONINFORMATION,"Linear regression and correlation program"
END SUB
' ------------------------------------------------
SUB Form1_ABOUT_Select
LOCAL St AS STRING
St="Linear regression and correlation program for PB for Windows 6 or 7. Program version 1.4 - January 22, 2004"+$CRLF+$CRLF+ _
"By Erik Christensen, Copenhagen, Denmark [email protected]"+$CRLF+$CRLF+ _
"The use of this Public Domain program and its consequences are your own responsibility. However, any comment you may have is welcome."+$CRLF+$CRLF+ _
"Good Luck!"
MSGBOX St,%MB_ICONINFORMATION,"About this program"
END SUB
' ------------------------------------------------
CALLBACK FUNCTION CBF_FORM1_BUTTONDOANALYSIS
LOCAL hCtl&,LineCount&,FirstVisLine&,Res&
' Get the final - perhaps edited - text and place it in T$
CONTROL GET TEXT hForm1&, %FORM1_TEXTRESULTS TO T$
EnableMenuItem hForm1_Menu2&, %Form1_GRAPHCOPY, %MF_BYCOMMAND OR %MF_GRAYED
CALL MakeAnalysis
CONTROL SET TEXT hForm1&,%FORM1_TEXTRESULTS,T$
CONTROL HANDLE hForm1&, %FORM1_TEXTRESULTS TO hCtl&
LineCount&=Edit_GetLineCount(hCtl&)
FirstVisLine&=Edit_GetFirstVisibleLine(hCtl&)
' scroll down to last analysis
Res&=Edit_LineScroll(hCtl&,0,LineCount&-FirstVisLine&-13)
CONTROL SET FOCUS hForm1&,%FORM1_TEXTRESULTS
res&=InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
END FUNCTION
' ------------------------------------------------
CALLBACK FUNCTION CBF_FORM1_COMBOBOXY
LOCAL CVal&,hCtl&,i&,res&,txt$,NoY&
' Return Current Selection in CVal&
CONTROL SEND CBHNDL , CBCTL, %CB_GETCURSEL, 0,0 TO CVal&
IF (CBCTLMSG=%CBN_SELCHANGE) OR (CBCTLMSG=%CBN_EDITCHANGE) OR (CBCTLMSG=%CBN_EDITUPDATE) THEN
' empty combobox X
COMBOBOX RESET hForm1&, %FORM1_COMBOBOXX
' put all numerical variables minus the selected Y-variable in combobox X
CONTROL HANDLE hForm1&, %FORM1_COMBOBOXY TO hCtl&
NoY&=SendMessage (hCtl&,%CB_GETCOUNT,0,0)
FOR i&=0 TO NoY&-1
CONTROL HANDLE hForm1&, %FORM1_COMBOBOXY TO hCtl&
res&=SendMessage (hCtl&,%CB_GETLBTEXTLEN,i&,0)
txt$=Combo_GetLbText(hCtl&,i&)
txt$=LEFT$(txt$,res&)
IF i&<>CVal& THEN
CONTROL HANDLE hForm1&, %FORM1_COMBOBOXX TO hCtl&
res&=Combo_AddString(hCtl&,txt$)
END IF
NEXT
CONTROL DISABLE hForm1&, %FORM1_BUTTONDOANALYSIS
END IF
END FUNCTION
' ------------------------------------------------
CALLBACK FUNCTION CBF_FORM1_COMBOBOXX
LOCAL CVal&
' Return Current Selection in CVal&
CVal&=-1
CONTROL SEND CBHNDL , CBCTL, %CB_GETCURSEL, 0,0 TO CVal&
IF CVal& > -1 THEN ' valid selection
CONTROL ENABLE hForm1&, %FORM1_BUTTONDOANALYSIS
END IF
END FUNCTION
' ------------------------------------------------
CALLBACK FUNCTION CBF_FORM1_BUTTONEXIT
LOCAL res&
res&=MSGBOX ("Are you sure?",%MB_YESNO OR %MB_ICONQUESTION ,"End?")
IF res&=%IDYES THEN DIALOG END hForm1&
END FUNCTION
' ------------------------------------------------
'
FUNCTION MakeFont(BYVAL FontTypeSize AS LONG,BYVAL FontWeight AS LONG, _
BYVAL Italic AS LONG, BYVAL Underline AS LONG,BYVAL StrikeOut AS LONG, _
BYVAL FaceName AS STRING) AS LONG
' -----------------------
'TYPE LOGFONT defines the attributes of a font.
'See LOGFONT in the Win32 help file
lfFont.lfHeight = -MulDiv(FontTypeSize,LogPixelsY,72) ' better than: -(FontTypeSize * LogPixelsY) \ 72
' logical height of font
lfFont.lfWidth = 0 ' logical average character width
lfFont.lfEscapement = 0 ' angle of escapement
lfFont.lfOrientation = 0 ' base-line orientation angle
lfFont.lfWeight = FontWeight ' font weight
lfFont.lfItalic = Italic ' italic attribute flag (0,1)
lfFont.lfUnderline = Underline ' underline attribute flag (0,1)
lfFont.lfStrikeOut = StrikeOut ' strikeout attribute flag (0,1)
lfFont.lfCharSet = %ANSI_CHARSET ' character set identifier
lfFont.lfOutPrecision = %OUT_TT_PRECIS ' output precision
lfFont.lfClipPrecision = %CLIP_DEFAULT_PRECIS ' clipping precision
lfFont.lfQuality = %DEFAULT_QUALITY ' output quality
lfFont.lfPitchAndFamily = %FF_DONTCARE ' pitch and family
lfFont.lfFaceName = FaceName ' typeface name string
' -----------------------
' Make font according to specifications
FUNCTION = CreateFontIndirect (lfFont)
END FUNCTION
' ------------------------------------------------
'
SUB CheckAndDisplayData()
LOCAL b$,i&,j&,k&,x&,M&,N&,hCtl&,alflag&,d$,l&,res&
LOCAL KK&,JJ&
LOCAL hListView AS LONG
' Find maximum string length for each column.
' Classify column as alphabetic or numerical.
REDIM MaxLen(Columns)
REDIM AlphNum(Columns)
FOR i&=1 TO Columns
MaxLen(i&)=LEN(head(i&)) ' start with header text length
AlphNum(i&)=1 ' presume numerical for a start
alflag&=1
FOR j&=1 TO Rows
d$=DAT(i&,j&)
k&=LEN(d$)
IF k&>MaxLen(i&) THEN MaxLen(i&)=k&
IF alflag&=1 THEN
FOR l&=1 TO k&
' If non-numerical characters found, then alphabetical
IF INSTR("0123456789.,+-ED ",MID$(d$, l&, 1)) = 0 THEN
AlphNum(i&)=0 ' alphabetical
alflag&=0
EXIT FOR
END IF
NEXT
END IF
NEXT
NEXT
'
' Display data using the listview control
' ***************************************
LOCAL LVC AS LV_COLUMN
LOCAL LVI AS LV_ITEM
LOCAL zText AS ASCIIZ * 255
LOCAL lstyle AS LONG
lvC.mask = %LVCF_FMT OR %LVCF_WIDTH OR %LVCF_TEXT OR %LVCF_SUBITEM
LVC.cchTextMax = 255
' Kill previous listview box. An easy way of clearing!
CONTROL KILL hForm1&,%FORM1_LISTVIEWBOX1
'
LISTBOX RESET hForm1&, %FORM1_LISTBOXROWHEAD ' empty listbox
'
' recreate listview box
CONTROL ADD "SysListView32", hForm1&, %FORM1_LISTVIEWBOX1,"",26, 8, 190, 126+RowHeadCorrect, _
%WS_border OR %WS_Child OR %WS_TABSTOP OR %LVS_Report , %WS_EX_CLIENTEDGE
CONTROL HANDLE hForm1&,%FORM1_LISTVIEWBOX1 TO hListView
lStyle = SendMessage(hListView, _
%LVM_GETEXTENDEDLISTVIEWSTYLE, 0, 0)
lStyle = lStyle OR %LVS_EX_GRIDLINES
CALL SendMessage(hListView, %LVM_SETEXTENDEDLISTVIEWSTYLE, _
0, BYVAL lStyle)
res& = ShowWindow(hListView,%SW_SHOW)
'
'By using the ListView_SetItemCount macro or the LVM_SETITEMCOUNT
'message before adding a large number of items, you enable a list
'view control to reallocate its internal data structures only once
'rather than every time you add an item.
ListView_SetItemCount hListView, Rows
'
' Display new data
' First make column headers
FOR KK& = 1 TO Columns
' calculate width of each column
lvC.cx = MaxLen(KK&)*HorizBaseU + 10
IF AlphNum(KK&)=0 THEN
lvC.fmt = %LVCFMT_LEFT ' left justify if alphabetical
ELSE '%LVCFMT_CENTER is another available style
lvC.fmt = %LVCFMT_RIGHT ' right justify if numerical
END IF
' column header text
zText = head(KK&)
LVC.pszText = VARPTR(zText)
CONTROL SEND hForm1&,%FORM1_LISTVIEWBOX1,%LVM_INSERTCOLUMN, KK&, VARPTR(lvc)
NEXT
' Then fill row and column grid with data - one row at a time
DIM Rec(Columns-1) AS STRING
CONTROL HANDLE hForm1&,%FORM1_LISTVIEWBOX1 TO hListView
FOR JJ&=1 TO Rows
FOR KK& = 1 TO Columns
rec(KK&-1)=DAT(KK&,JJ&)
NEXT
'
' Put number of row in this lefthand listbox
' to simulate a row header
LISTBOX ADD hForm1&, %FORM1_LISTBOXROWHEAD, RIGHT$("00000"+LTRIM$(STR$(JJ&)) ,5)
'
' Append each set of row data to the listview control
CALL AppendListView (hListView, Rec())
NEXT
' The reason for this line becomes clear when
' you see the display with and without the horizontal scroll bar.
LISTBOX ADD hForm1&, %FORM1_LISTBOXROWHEAD, RIGHT$("00000"+LTRIM$(STR$(Rows+1)) ,5)
' empty comboboxes
COMBOBOX RESET hForm1&, %FORM1_COMBOBOXY
COMBOBOX RESET hForm1&, %FORM1_COMBOBOXX
'
' add variable headers to combobox Y for numerical variables only
FOR i&=0 TO Columns-1
IF Columns>=1 AND AlphNum(i&+1)=1 THEN COMBOBOX ADD hForm1&, %FORM1_COMBOBOXY, head(i&+1)
NEXT
END SUB
'
'
SUB AppendListView (hList AS LONG, Rec() AS STRING )
DIM z AS INTEGER
DIM iStatus AS INTEGER
DIM szStr AS ASCIIZ * 300
DIM lvi AS LV_ITEM
LOCAL x AS LONG
'this will be the next record
lvi.iItem = ListView_GetItemCount(hList)
'The ListView_GetItemCount macro retrieves the number of items
'in a list view control. You can use this macro or explicitly
'send the LVM_GETITEMCOUNT message.
'
lvi.mask = %LVIF_TEXT
lvi.stateMask = 0 '%LVIS_FOCUSED '%LVIS_SELECTED
lvi.pszText = VARPTR(szStr)
FOR z = 0 TO UBOUND(Rec)
szStr = Rec(z)
lvi.iSubItem = z
lvi.lParam = lvi.iItem
IF z = 0 THEN
lvi.mask = %LVIF_TEXT 'OR %LVIF_PARAM OR %LVIF_STATE
iStatus = ListView_InsertItem (hList, lvi)
'The ListView_InsertItem macro inserts a new item in a list view control.
'The iItem member specifies the index of the new item.
'You cannot use ListView_InsertItem to insert subitems;
'the iSubItem member of the LV_ITEM structure must be zero.
ELSE
lvi.mask = %LVIF_TEXT 'OR %LVIF_PARAM OR %LVIF_STATE
iStatus = ListView_SetItem (hList, lvi)
'The ListView_SetItem macro sets some or all of a list view item's attributes.
END IF
NEXT
END SUB
' ------------------------------------------------
FUNCTION FilNameSaveEMF() AS LONG
LOCAL Path AS STRING
LOCAL f AS STRING
LOCAL Style AS DWORD
igen:
PAFUemf=""
Path=FilePath(PAFU)
f=""
Style = %OFN_HIDEREADONLY OR %OFN_LONGNAMES
IF SaveFileDialog(0, "Save Current Graph", f, Path, _
"Enhanced Metafiles|*.emf|All Files|*.*", "emf", Style) THEN
PAFUemf=f
FUNCTION = 1
END IF
END FUNCTION
' ------------------------------------------------
FUNCTION FilNameSave() AS LONG
LOCAL Path AS STRING
LOCAL f AS STRING
LOCAL Style AS DWORD
LOCAL hFile AS LONG
LOCAL i&,j&,res&,fl&
igen:
PAFUout=""
Path=FilePath(PAFU)
f=""
Style = %OFN_HIDEREADONLY OR %OFN_LONGNAMES
IF SaveFileDialog(0, "Save File", f, Path, _
"Text Files|*.txt|All Files|*.*", "txt", Style) THEN
'
PAFUout=f
IF PAFU=PAFUout THEN
res& = MSGBOX ("Output file name the same as input file name. Do you want this ?",%MB_ICONHAND OR %MB_YESNO, "Problem:")
IF res&=%IDNO THEN GOTO igen
END IF
hFile = FREEFILE
OPEN PAFUout FOR OUTPUT AS hFile
Delim = $TAB ' saves in TAB-delimited text format.
' This format can be imported in most
' spreadsheet and data base programs
' like EXCEL and ACCESS.
' First save the column header line
FOR i&=1 TO Columns
PRINT# hFile, head(i&);
' put delimiter after each column header
' except the last
IF i&<Columns THEN PRINT# hFile,Delim;
NEXT
PRINT# hFile, $CRLF; ' start a new line
' Then save the data - one row at a time
FOR j&=1 TO Rows
FOR i&=1 TO Columns
PRINT# hFile, DAT(i&,j&);
' put delimiter after each field
' except the last
IF i&<Columns THEN PRINT# hFile,Delim;
NEXT
PRINT# hFile, $CRLF; ' start a new line
NEXT
CLOSE hFile
FUNCTION = 1
END IF
END FUNCTION
' ------------------------------------------------
FUNCTION FilNameOpen() AS LONG
LOCAL Path AS STRING
LOCAL f AS STRING
LOCAL Style AS DWORD
LOCAL A$
LOCAL hFile AS LONG
LOCAL b$,i&,j&,k&,x&,M&,N&,hCtl&,alflag&,d$,l&
LOCAL KK&,JJ&
LOCAL hListView AS LONG
Path = CURDIR$
igen:
f = "*.TXT"
Style = %OFN_FILEMUSTEXIST OR %OFN_HIDEREADONLY OR %OFN_LONGNAMES
IF OpenFileDialog(0, "Open File", f, Path, _
"Text Files|*.txt|All Files|*.*", "txt", Style) THEN
PAFU=f
Rows = 0
hFile = FREEFILE
OPEN PAFU FOR INPUT AS hFile
LINE INPUT# hFile, b$
' Delimiter:
Delim = $TAB
' TAB (CHR$(9)) delimited text data without quotes are
' assumed in this version.
'
' Most spreadsheet and data base programs can export data
' in TAB-separated text format to be read by this program.
' If you so wishes you can also use other delimiters, such
' as comma, semicolon etc.
'
x& = PARSECOUNT(b$,Delim) ' Number of columns or data per row.
' Fields without quotes assumed.
' check file
IF x&<1 THEN ' too few delimiters
MSGBOX "This file cannot be read by this program!"+$CRLF+" Try again.",%MB_ICONHAND,"Problem:"
CLOSE hFile
GOTO igen
END IF
k&=0
DO WHILE NOT (EOF(hFile) OR k&>20)
INCR k&
LINE INPUT# hFile, b$
j& = PARSECOUNT(b$,Delim)
IF j&<>x& THEN ' not the same number of fields per line
MSGBOX "This file cannot be read by this program!"+$CRLF+" Try again.",%MB_ICONHAND,"Problem:"
CLOSE hFile
GOTO igen
END IF
LOOP
IF k&<2 THEN ' too few lines
MSGBOX "This file cannot be read by this program!"+$CRLF+" Try again.",%MB_ICONHAND,"Problem:"
CLOSE hFile
GOTO igen
END IF
CLOSE hFile
' Checking OK. Now read the file from start to end.
' =================================================
hFile = FREEFILE
OPEN PAFU FOR INPUT AS hFile
Columns=x& ' number of columns
LINE INPUT# hFile, b$
' Read the data in the file.
' If the first row contains non-numerical characters it is assumed
' to be column headers - if not, the program makes default column headers
REDIM head(1:Columns)
LOCAL CHflag&,Cstr$ : Cstr$ = "0123456789.+-ED"+Delim+$CRLF
CHflag = VERIFY(b$,Cstr$)
FOR i&=1 TO Columns
IF ISTRUE CHflag THEN
head(i&)=PARSE$(b$,Delim,i&)
ELSE
head(i&)="Var."+STR$(i&)
END IF
NEXT
'
' Redimension DAT array. Important to set the right number of columns
' prior to using REDIM PRESERVE
REDIM DAT(1:Columns,1:1)
Rows=0
IF ISFALSE Chflag THEN ' include the first line as data
INCR Rows
REDIM PRESERVE DAT(1:Columns,1:Rows)
FOR i&=1 TO Columns
DAT(i&,Rows)=PARSE$(b$,Delim,i&)
NEXT
END IF
'
' read data into DAT array - one row at a time
DO WHILE NOT EOF(hFile)
INCR Rows ' number of rows
LINE INPUT# hFile, b$
REDIM PRESERVE DAT(1:Columns,1:Rows)
FOR i&=1 TO Columns
DAT(i&,Rows)=PARSE$(b$,Delim,i&)
NEXT
LOOP
CLOSE hFile
FUNCTION = 1
END IF
END FUNCTION
' ------------------------------------------------
FUNCTION FileNam(BYVAL Src AS STRING) AS STRING
LOCAL x AS LONG
FOR x = LEN(Src) TO 1 STEP -1
IF (ASC(Src, x) = 92) OR (ASC(Src, x) = 58) THEN EXIT FOR
NEXT x
FUNCTION = MID$(Src, x + 1)
END FUNCTION
' ------------------------------------------------
FUNCTION FilePath(BYVAL Src AS STRING) AS STRING
LOCAL x AS LONG
FOR x = LEN(Src) TO 1 STEP -1
IF (ASC(Src, x) = 92) OR (ASC(Src, x) = 58) THEN EXIT FOR
NEXT x
FUNCTION = LEFT$(Src, x)
END FUNCTION
'
FUNCTION gammln(num AS DOUBLE) AS DOUBLE 'logGamma function
' Thanks to Tony Burcham who provided this fine function.
LOCAL fl AS EXT
LOCAL j AS LONG
LOCAL k AS EXT
LOCAL z AS EXT
LOCAL zpwr AS EXT 'power of z
LOCAL zsqr AS EXT 'z squared
DIM cf(5) AS EXT
cf(0) = 1## / 12##
cf(1) = 1## / -360##
cf(2) = 1## / 1260##
cf(3) = 1## / -1680##
cf(4) = 1## / 1188##
FOR k = 0## TO 10##
fl = fl - LOG(num + k )
NEXT k
z = num + 11##
zpwr = z 'z^1
zsqr = z * z
FOR j = 0 TO 4
fl = fl + ( cf(j) / zpwr)
zpwr = zpwr * zsqr
NEXT j
fl = fl + ((z - 0.5##) * LOG(z)) + 0.9189385332046727## - z
FUNCTION = fl
' Gam = EXP(fl)
END FUNCTION
'
SUB IncomplBeta(BYVAL X AS DOUBLE,BYVAL P AS DOUBLE,BYVAL Q AS DOUBLE,BYREF betain AS DOUBLE,BYREF ifault AS LONG)
'
' Derived from FORTRAN code based on:
'
' algorithm AS 63 appl. statist. (1973), vol.22, no.3
'
' computes incomplete beta function ratio for arguments
' x between zero and one, p and q positive.
'
LOCAL indx&,beta##
LOCAL zero##,one##,acu##
LOCAL psq##,cx##,xx##,pp##,qq##,term##,ai##,ns&,rx##,temp##
'
' define accuracy and initialise
'
zero = 0.0E0## : one = 1.0E0## : acu = 0.1E-13##
betain=x
'
' test for admissibility of arguments
'
ifault=1&
IF(p <= zero OR q <= zero) THEN EXIT SUB
ifault=2&
IF(x < zero OR x > one) THEN EXIT SUB
ifault=0&
IF(x = zero OR x = one) THEN EXIT SUB
'
' calculate log of complete beta
'
beta = gammln(p)+gammln(q)-gammln(p+q)
'
' change tail if necessary and determine s
'
psq=p+q
cx=one-x
IF(p >= psq*x) GOTO 1
xx=cx
cx=x
pp=q
qq=p
indx = 1&
GOTO 2
1 xx=x
pp=p
qq=q
indx = 0&
2 term=one
ai=one
betain=one
ns=qq+cx*psq
'
' user Soper's reduction formulae.
'
rx=xx/cx
3 temp=qq-ai
IF(ns = 0&) THEN rx=xx
4 term=term*temp*rx/(pp+ai)
betain=betain+term
temp=ABS(term)
IF(temp <= acu AND temp <= acu*betain) THEN GOTO 5
ai=ai+one
ns=ns-1&
IF(ns >= 0&) THEN GOTO 3
temp=psq
psq=psq+one
GOTO 4
'
' calculate result
'
5 betain=betain*EXP(pp*LOG(xx)+(qq-one)*LOG(cx)-beta)/pp
IF indx = 1& THEN betain=one-betain
END SUB
'
FUNCTION PfromT(BYVAL T AS DOUBLE,BYVAL df AS DOUBLE) AS DOUBLE
LOCAL ifault&,betain#
CALL IncomplBeta(df/(df+T*T),df*.5#,.5#,betain,ifault)
IF ifault = 0 THEN FUNCTION = betain ELSE FUNCTION = 1
END FUNCTION
'
SUB MakeAnalysis
LOCAL I&,J&,tt$,K&
LOCAL Cval&,hCtl&,Length&,Cvartx$
INCR AnalysisNumber
' Identify Yvar - number.
CONTROL HANDLE hForm1&, %FORM1_COMBOBOXY TO hCtl&
Cval&=Combo_GetCurSel(hCtl&) ' get current selection index
Length&=SendMessage (hCtl&,%CB_GETLBTEXTLEN,CVal&,0)
' get selected text without extra spaces
Cvartx$=LEFT$(Combo_GetLbText(hCtl&,CVal&),Length&)
FOR I&=1 TO Columns
IF Cvartx$ = head(I&) THEN Yvar&=I&
NEXT
' Identify Xvar - number.
CONTROL HANDLE hForm1&, %FORM1_COMBOBOXX TO hCtl&
Cval&=Combo_GetCurSel(hCtl&) ' get current selection index
Length&=SendMessage (hCtl&,%CB_GETLBTEXTLEN,CVal&,0)
' get selected text without extra spaces
Cvartx$=LEFT$(Combo_GetLbText(hCtl&,CVal&),Length&)
FOR I&=1 TO Columns
IF Cvartx$ = head(I&) THEN Xvar&=I&
NEXT
' Transfer selected data to numerical array
' and find minimum and maximum values for X and Y
REDIM NumDat(1:Rows,0:2)
Xmax = 1E-33: Ymax = 1E-33: Xmin = 1E+33: Ymin = 1E+33
K&=0
FOR J&=1 TO Rows
' include only complete data in the analysis
IF TRIM$(DAT(Xvar&,J&))<>"" AND TRIM$(DAT(Yvar&,J&))<>"" THEN
INCR K&
NumDat(K&,0)=1
NumDat(K&,1)=VAL(DAT(Xvar&,J&))
IF NumDat(K&,1)>Xmax THEN Xmax=NumDat(K&,1)
IF NumDat(K&,1)<Xmin THEN Xmin=NumDat(K&,1)
NumDat(K&,2)=VAL(DAT(Yvar&,J&))
IF NumDat(K&,2)>Ymax THEN Ymax=NumDat(K&,2)
IF NumDat(K&,2)<Ymin THEN Ymin=NumDat(K&,2)
END IF
NEXT
RowsNew=K& ' number of x,y data sets included in the analysis
'
DIM X(2,2) AS DOUBLE, A(2,2) AS DOUBLE, Y(2) AS DOUBLE, _
Mean(2) AS DOUBLE, StDev(2) AS DOUBLE, T(2) AS DOUBLE, _
B(2) AS DOUBLE, U(2,2) AS DOUBLE, R(2,2) AS DOUBLE, _
C(2,2) AS DOUBLE, X AS DOUBLE, N AS DOUBLE, M AS LONG
M=2
N=RowsNew
LOCAL L&
LOCAL DET AS DOUBLE,SSS AS DOUBLE,TTTT AS DOUBLE, UUU AS DOUBLE
' calculate cross products
FOR I& = 0 TO M
FOR J& = 0 TO M
X = 0
FOR L& = 1 TO RowsNew
X = X + NumDat(L&,I&) * NumDat(L&,J&)
NEXT
X(I&,J&) = X ' sum of cross products
C(I&,J&) = X
NEXT
T(I&) = X(0,I&) / X(0,0) ' Means
B(I&) = 0
IF I& > 0 THEN B(I&) = SQR(X(I&,I&)/(N-1)-X(0,I&)*X(0,I&)/(N*(N-1))) ' Standard Deviation (SD)
NEXT
'
FOR I = 1 TO M
Mean(I) = T(I)
StDev(I) = B(I)
NEXT
T$=T$+"Analysis"+STR$(AnalysisNumber)+". Number of individuals in analysis:"+STR$(RowsNew)+$CRLF+ _
"Y-variable: "+head(Yvar&)+" Mean:"+FORMAT$(Mean(2),"######.#####")+ _
" SD:"+FORMAT$(StDev(2),"######.#####")+ $CRLF+ _
"X-variable: "+head(Xvar&)+" Mean:"+FORMAT$(Mean(1),"######.#####")+ _
" SD:"+FORMAT$(StDev(1),"######.#####")+ $CRLF
'
FOR I& = 1 TO M
FOR J& = 1 TO M
R(I&,J&)=(N*X(I&,J&)-X(0,I&)*X(0,J&))/(N*(N - 1)*B(I&)*B(J&))
NEXT
NEXT
'
FOR I& = 1 TO M
FOR J& = 1 TO M
U(I&,J&) = R(I&,J&)
NEXT
NEXT
LOCAL t3#,pp#,NN#,st$ : NN=RowsNew
st = $CRLF
IF (U(1,2)^2) < 0.999 THEN
t3=U(1,2)*SQR((NN-2#)/(1#-U(1,2)^2)) : pp = PfromT(t3,N-2#) : st = " t: " + FORMAT$(t3,"####.##") + " p: "+FORMAT$(pp,"##.######")+$CRLF
IF pp<0.000001 THEN st$= " t: " + FORMAT$(t3,"####.##") + " p: <0.000001"+$CRLF
END IF
T$=T$+"Correlation Coefficient r: "+FORMAT$(U(1,2),"##.#####")
T$=T$+st
T$=T$+"Coefficient of Determination r²: "+FORMAT$(U(1,2)^2,"##.#####")+$CRLF
FOR I& = 0 TO 1
Y(I&) = C(I&, M)
FOR J& = 0 TO 1
X(I&,J&) = C(I&,J&)
NEXT
NEXT
'
CALL MATINVSIM(A(), 1, DET, X(), Y())
IF DET=0 THEN
T$=T$+"Cannot perform the analysis."+$CRLF+$CRLF
GRAFFLAG = 0 ' No plot is made
EXIT SUB
END IF
SSS = C(M, M)
FOR I& = 0 TO 1
SSS = SSS - Y(I&) * C(I&, M)
NEXT
TTTT = SSS / (N - M)
UUU = SQR(TTTT)
' VARIANCE-COVARIANCE MATRIX
FOR I& = 0 TO 1
FOR J& = 0 TO 1
A(I&, J&) = A(I&, J&) * TTTT
NEXT
NEXT
Coeff=Y(1):Constant=Y(0)
st = $CRLF
IF ABS(A(1,1)) > ABS(y(1)) *10E-10 THEN
t3=Y(1)/SQR(A(1,1)) : pp = PfromT(t3,N-2#) : st = " t: " + FORMAT$(t3,"####.##") + " p: "+FORMAT$(pp,"##.######")+$CRLF
IF pp<0.000001 THEN st$= " t: " + FORMAT$(t3,"####.##") + " p: <0.000001"+$CRLF
END IF
T$=T$+"Regres. Coeff.: "+FORMAT$(Y(1),"#####.#####")+" Standard Error: "+FORMAT$(SQR(A(1,1)),"#####.#####") + st
st = $CRLF
IF ABS(A(0,0)) > ABS(y(0)) *10E-10 THEN
t3=Y(0)/SQR(A(0,0)) : pp = PfromT(t3,N-2#) : st = " t: "+ FORMAT$(t3,"####.##") + " p: "+FORMAT$(pp,"##.######")+$CRLF
IF pp<0.000001 THEN st$= " t: " + FORMAT$(t3,"####.##") + " p: <0.000001"+$CRLF
END IF
T$=T$+"Constant: "+FORMAT$(Y(0),"#####.#####")+" Standard Error: "+FORMAT$(SQR(A(0,0)),"#####.#####") + st
I&=SGN(Y(1)) : IF I&=1 THEN tt$=" +" ELSE tt$=" -"
T$=T$+"Regression equation: Y ="+FORMAT$(Y(0),"#####.#####")+tt$+FORMAT$(ABS(Y(1)),"#####.#####")+" * X"+$CRLF
T$=T$+"Standard Error of Estimated Y: "+FORMAT$(UUU,"#####.#####")+$CRLF
T$=T$+$CRLF+$CRLF
GRAFFLAG=10
EnableMenuItem hForm1_Menu2&, %Form1_GRAPHCOPY, %MF_BYCOMMAND OR %MF_ENABLED
END SUB
'
'
SUB MATINVSIM (BYREF X() AS DOUBLE, BYVAL M AS LONG, BYREF DET AS DOUBLE, BYREF A() AS DOUBLE, BYREF Y() AS DOUBLE)
LOCAL PVT AS DOUBLE,T AS DOUBLE
LOCAL J&,K&,L&,I&
DET = 1
FOR J& = 0 TO M
PVT = A(J&, J&)
DET = DET * PVT
IF DET = 0 THEN MSGBOX "MATRIX SINGULAR - Cannot perform the analysis",%MB_ICONERROR,"Calculation Problem": EXIT SUB
Y(J&) = Y(J&) / A(J&, J&)
A(J&, J&) = 1
FOR K& = 0 TO M
A(J&, K&) = A(J&, K&) / PVT
NEXT
FOR K& = 0 TO M
IF K& <> J& THEN
T = A(K&, J&)
Y(K&) = Y(K&) - T * Y(J&)
A(K&, J&) = 0
FOR L& = 0 TO M
A(K&, L&) = A(K&, L&) - A(J&, L&) * T
NEXT
END IF
NEXT
NEXT
FOR I& = 0 TO M
FOR J& = 0 TO M
X(I&, J&) = A(I&, J&)
NEXT
NEXT
END SUB
'
'
SUB PrepareAndMakeGraph (BYVAL hDC AS LONG,BYVAL NV AS LONG,BYVAL NP AS LONG,BYVAL Xmax AS SINGLE, _
BYVAL Xmin AS SINGLE,BYVAL Ymax AS SINGLE,BYVAL Ymin AS SINGLE,BYVAL IIX AS LONG, _
BYVAL IIY AS LONG,BYREF NumDat() AS SINGLE,BYVAL Xtxt$,BYVAL Ytxt$)
' -
DIM Start AS SINGLE,StepSize AS SINGLE, Labels AS LONG
DIM Xstep AS SINGLE,Xlabels AS LONG, Xhigh AS SINGLE
DIM Ystep AS SINGLE,Ylabels AS LONG, Yhigh AS SINGLE
DIM Xlow AS SINGLE, Ylow AS SINGLE
DIM LeMarg AS SINGLE, RiMarg AS SINGLE, UpMarg AS SINGLE, LoMarg AS SINGLE
DIM XConvFac AS SINGLE, YConvFac AS SINGLE
LOCAL I&,hPen AS LONG
LOCAL Xpix AS SINGLE,Ypix AS SINGLE, Radius AS SINGLE
LOCAL Ystart AS SINGLE,Yend AS SINGLE,PenWidth AS SINGLE
'
FillRect hDC, Rct, GetStockObject(%WHITE_BRUSH)
IF ABS(Xmax) > ABS(Xmin) THEN
PowerX = Xmax
ELSE
PowerX = Xmin
END IF
PowerX = INT(LOG10(ABS(PowerX) / 10))
IF ABS(Ymax) > ABS(Ymin) THEN
PowerY = Ymax
ELSE
PowerY = Ymin
END IF
PowerY = INT(LOG10(ABS(PowerY) / 10))
CALL FindAxisDimAndScale(Xmax, Xmin, Xlow, Xstep, Xlabels)
CALL FindAxisDimAndScale(Ymax, Ymin, Ylow, Ystep, Ylabels)
Xhigh = Xlow + (Xlabels - 1) * Xstep
Yhigh = Ylow + (Ylabels - 1) * Ystep
' Define wideness of "margins" for plot
LeMarg = XPixMax&/8
RiMarg = XPixMax&/12
UpMarg = YPixMax&/8
LoMarg = YPixMax&/6
XConvFac = (XPixMax& - LeMarg - RiMarg) / (Xhigh - Xlow)
YConvFac = (YPixMax& - UpMarg - LoMarg) / (Yhigh - Ylow)
CALL MakeXandYaxisWithText(hDC,LeMarg, LoMarg, RiMarg, UpMarg, Xlow, Xstep, Xhigh, _
Ylow, Ystep, Yhigh, XConvFac, YConvFac, Xtxt$, Ytxt$, 0)
'
PenWidth=LogPixelsX/254*2.1
hPen = SelectObject(hDC, CreatePen(PenStyle(0), PenWidth, gColor(1))) ' blue
' Plot points
' ===========
Radius=ROUND((XPixMax&/100),0)
FOR I&=1 TO RowsNew
Xpix=ROUND((NumDat(I&,1)-Xlow)*XConvFac+LeMarg,0)
Ypix=ROUND(YPixMax&-((NumDat(I&,2)-Ylow)*YConvFac+LoMarg),0)
' Draw small circle for each point. You can change the
' dimensions of the circle if you like.
Ellipse hDC, Xpix-Radius,Ypix-Radius,Xpix+Radius,Ypix+Radius
NEXT
' Draw regression line:
' =====================
Ystart=Constant+Coeff*Xlow
Yend=Constant+Coeff*Xhigh
' 1: Move to left starting point
IF Ystart<=Yhigh AND Ystart>=Ylow THEN
MoveToEx hDC, LeMarg,YPixMax&-((Ystart-Ylow)*YConvFac+LoMarg), BYVAL %NULL
ELSEIF Ystart>Yhigh THEN
MoveToEx hDC,((Yhigh-Constant)/Coeff-Xlow)*XConvFac+LeMarg,UpMarg,BYVAL %NULL
ELSE 'Ystart<Ylow
MoveToEx hDC,((Ylow-Constant)/Coeff-Xlow)*XConvFac+LeMarg,YPixMax&-LoMarg,BYVAL %NULL
END IF
' 2: Draw to right ending point
IF Yend<=Yhigh AND Yend>=Ylow THEN
LineTo hDC, XPixMax&-RiMarg,YPixMax&-((Yend-Ylow)*YConvFac+LoMarg)
ELSEIF Yend>Yhigh THEN
LineTo hDC,((Yhigh-Constant)/Coeff-Xlow)*XConvFac+LeMarg,UpMarg
ELSE 'Yend<Ylow
LineTo hDC,((Ylow-Constant)/Coeff-Xlow)*XConvFac+LeMarg,YPixMax&-LoMarg
END IF
END SUB
'
'
SUB FindAxisDimAndScale (BYVAL MaxVal AS SINGLE,BYVAL MinVal AS SINGLE,BYREF Start AS SINGLE,BYREF StepSize AS SINGLE,BYREF Labels AS LONG)
LOCAL Range AS DOUBLE,EKSP AS DOUBLE,Bbbb AS DOUBLE, III AS LONG
Range = MaxVal - MinVal
Range = LOG10(Range)
EKSP = CEIL(Range)
Range = 10 ^ (Range - EKSP)
WHILE Range < 1
Range = Range * 10
EKSP = EKSP - 1
WEND
IF CEIL(Range) >= 5 THEN
Labels = CEIL(Range) + 1
StepSize = 1 * 10 ^ EKSP
ELSEIF CEIL(Range) >= 2 THEN
Labels = CEIL(2 * Range) + 1
StepSize = .5 * 10 ^ EKSP
ELSE
Labels = CEIL(5 * Range) + 1
StepSize = .2 * 10 ^ EKSP
END IF
Bbbb = 0
IF MaxVal > 0 THEN
III = 1
DO
III = III + 1
Bbbb = Bbbb + StepSize
LOOP UNTIL Bbbb > MaxVal
IF (III - Labels) * StepSize > MinVal THEN Labels = Labels + 1
Start = (III - Labels) * StepSize
ELSE
III = 0
DO
III = III -1
Bbbb = Bbbb - StepSize
LOOP UNTIL Bbbb < MinVal
IF (III + Labels - 1) * StepSize < MaxVal THEN Labels = Labels + 1
Start = III * StepSize
END IF
END SUB
'
'
SUB MakeXandYaxisWithText (BYVAL hDC AS LONG,BYVAL LeMarg AS SINGLE,BYVAL LoMarg AS SINGLE,BYVAL RiMarg AS SINGLE,BYVAL UpMarg AS SINGLE, _
BYVAL Xlow AS SINGLE,BYVAL Xstep AS SINGLE,BYVAL Xhigh AS SINGLE,BYVAL Ylow AS SINGLE,BYVAL Ystep AS SINGLE, _
BYVAL Yhigh AS SINGLE,BYVAL XConvFac AS SINGLE,BYVAL YConvFac AS SINGLE, BYVAL Xtxt$, _
BYVAL Ytxt$,BYVAL IPAT AS LONG)
'-
DIM lpsz AS ASCIIZ * 255
LOCAL hPen AS LONG,Fontt&
LOCAL I AS LONG, flag AS LONG, KK AS LONG, LongTics AS LONG
LOCAL res AS LONG
LOCAL SI AS SINGLE,EX$,XX1 AS SINGLE
LOCAL YY1 AS SINGLE
LOCAL Xval AS SINGLE,Yval AS SINGLE,PenWidth AS SINGLE
'-
res=FillRect(hDC, Rct, GetStockObject(%WHITE_BRUSH))
'
' An attempt to accomodate both large and small Windows font setting.
IF Xfact>1.75 THEN ' large font
Fontt&=MakeFont(8,400,0,0,0,"Arial")
ELSE ' small font
Fontt&=MakeFont(7,400,0,0,0,"Arial")
END IF
SelectObject hDC, Fontt&
SetTextAlign hDC,%TA_LEFT
PenWidth=LogPixelsX/254*2.1
hPen = SelectObject(hDC, CreatePen(PenStyle(0), PenWidth, gColor(0))) ' black pen
'- Draw X-axis and Y-axis
MoveToEx hDC, XPixMax&-RiMarg,YPixMax&-LoMarg, BYVAL %NULL
LineTo hDC, LeMarg,YPixMax&-LoMarg
LineTo hDC, LeMarg,UpMarg
'
' Check number of ciphers in tic labels on x-axis
Xval = Xlow
FOR SI = LeMarg TO XPixMax& - RiMarg STEP XConvFac * Xstep * .9999
IF ABS(PowerX)>=3 THEN
XX1 = INT(Xval / 10 ^ PowerX + .5)
ELSE
XX1=ROUND(Xval,3)
END IF
Xval = Xval + Xstep
IF ABS(XX1)>=100 THEN LongTics = 1
INCR KK
NEXT
IF LongTics = 1 AND KK >=8 THEN flag = 1 ' Many long tic labels.
'
'- Make tic intervals and labels on X-axis
Xval = Xlow : KK = 0
SetTextAlign hDC,%TA_CENTER
FOR SI = LeMarg TO XPixMax& - RiMarg STEP XConvFac * Xstep * .9999
IF ABS(PowerX)>=3 THEN
XX1 = INT(Xval / 10 ^ PowerX + .5)
ELSE
XX1=ROUND(Xval,3)
END IF
lpsz = LTRIM$(STR$(XX1))
res=GetTextExtentPoint32(hDC,lpsz,BYVAL LEN(lpsz),lpSize)
INCR KK
IF flag = 1 THEN ' Only show every other tic label
IF KK MOD 2 = 1 THEN TextOut hDC, SI, YPixMax&-LoMarg+YPixMax&/40, lpsz, BYVAL LEN(lpsz)
IF KK MOD 2 = 0 THEN lpSize.cx = 0
ELSE ' Show every tic label
TextOut hDC, SI, YPixMax&-LoMarg+YPixMax&/40, lpsz, BYVAL LEN(lpsz)
END IF
MoveToEx hDC, SI,YPixMax&-LoMarg, BYVAL %NULL
LineTo hDC, SI,YPixMax&-LoMarg+YPixMax&/50
Xval = Xval + Xstep
NEXT
'- Put name of X-variable on diagram
IF PowerX >=3 THEN EX$ = " / 10^" + MID$(STR$(-PowerX), 2)
IF ABS(PowerX)<3 THEN EX$ = ""
IF PowerX <=-3 THEN EX$ = " x 10^" + MID$(STR$(PowerX), 2)
Xtxt$ = Xtxt$ + EX$
lpsz=Xtxt$
SetTextAlign hDC,%TA_RIGHT
TextOut hDC, XPixMax&-RiMarg+lpSize.cx*0.5, YPixMax&-LoMarg+YPixMax&/11, lpsz, BYVAL LEN(lpsz)
'- Make tic intervals and labels on Y-axis
Yval = Ylow
FOR SI = YPixMax&-LoMarg TO UpMarg STEP -YConvFac * Ystep * .9999
IF ABS(PowerY)>=3 THEN
YY1 = INT(Yval / 10 ^ PowerY + .5)
ELSE
YY1=ROUND(Yval,3)
END IF
lpsz = LTRIM$(STR$(YY1))
res=GetTextExtentPoint32(hDC,lpsz,BYVAL LEN(lpsz),lpSize)
TextOut hDC, LeMarg-XPixMax&/40, SI-lpSize.cy*0.5, lpsz, BYVAL LEN(lpsz)
Yval = Yval + Ystep
MoveToEx hDC,LeMarg, SI, BYVAL %NULL
LineTo hDC, LeMarg-XPixMax&/70,SI
NEXT
'-Put name of Y-variable on diagram
IF PowerY >= 3 THEN EX$ = " / 10^" + MID$(STR$(-PowerY), 2)
IF ABS(PowerY) <3 THEN EX$ = ""
IF PowerY < -3 THEN EX$ = " x 10^" + MID$(STR$(PowerY), 2)
Ytxt$ = Ytxt$ + EX$
lpsz=Ytxt$
SetTextAlign hDC,%TA_LEFT
TextOut hDC, LeMarg-XPixMax&/40-lpSize.cx,UpMarg-YPixMax&/10, lpsz, BYVAL LEN(lpsz)
END SUB
'
'
FUNCTION gColor(BYVAL I AS LONG) AS LONG
SELECT CASE I
' Common RGB Colors:
CASE 0 : FUNCTION = &H000000??? '%Black - same as RGB(0,0,0)
CASE 1 : FUNCTION = &HFF0000??? '%Blue
CASE 2 : FUNCTION = &H00FF00??? '%Green
CASE 3 : FUNCTION = &HFFFF00??? '%Cyan
CASE 4 : FUNCTION = &H0000FF??? '%Red
CASE 5 : FUNCTION = &HFF00FF??? '%Magenta
CASE 6 : FUNCTION = &H00FFFF??? '%Yellow
CASE 7 : FUNCTION = &HFFFFFF??? '%White - same as RGB(255,255,255)
CASE 8 : FUNCTION = &H808080??? '%Gray
CASE 9 : FUNCTION = &HC0C0C0??? '%LtGray
' Additional colors can be added e.g. using the RGB function,
' e.g. CASE 10: FUNCTION = RGB(164,164,164)
' and so on.
CASE ELSE : FUNCTION = &H000000??? '%Black
END SELECT
END FUNCTION
'
'
FUNCTION PenStyle(BYVAL I AS LONG) AS LONG
SELECT CASE I
' Pen Styles
CASE 0 : FUNCTION = 0 '%PS_SOLID _______
CASE 1 : FUNCTION = 1 '%PS_DASH -------
CASE 2 : FUNCTION = 2 '%PS_DOT .......
CASE 3 : FUNCTION = 3 '%PS_DASHDOT _._._._
CASE 4 : FUNCTION = 4 '%PS_DASHDOTDOT _.._.._
CASE ELSE: FUNCTION = 0 '%PS_SOLID
END SELECT
END FUNCTION
[This message has been edited by Erik Christensen (edited January 23, 2004).]
at
Comment