Files
lazarus-ccr/applications/lazstats/source/forms/analysis/multiple_regression/coxregunit.pas
wp_xxyyzz 29721742a0 LazStats: Less hints and warnings.
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@7897 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2020-11-22 18:49:28 +00:00

657 lines
16 KiB
ObjectPascal

unit CoxRegUnit;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs,
StdCtrls, Buttons, ExtCtrls,
Globals, MainUnit, BasicStatsReportFormUnit;
type
{ TCoxRegForm }
TCoxRegForm = class(TBasicStatsReportForm)
InBtn: TBitBtn;
OutBtn: TBitBtn;
DepInBtn: TBitBtn;
DepOutBtn: TBitBtn;
StatusInBtn: TBitBtn;
StatusOutBtn: TBitBtn;
DescChk: TCheckBox;
MaxItsEdit: TEdit;
Label5: TLabel;
ProbsChk: TCheckBox;
ItersChk: TCheckBox;
DepVar: TEdit;
GroupBox1: TGroupBox;
StatusEdit: TEdit;
Label1: TLabel;
Label2: TLabel;
BlockList: TListBox;
Label3: TLabel;
Label4: TLabel;
VarList: TListBox;
procedure BlockListDblClick(Sender: TObject);
procedure DepInBtnClick(Sender: TObject);
procedure DepOutBtnClick(Sender: TObject);
procedure InBtnClick(Sender: TObject);
procedure OutBtnClick(Sender: TObject);
procedure StatusInBtnClick(Sender: TObject);
procedure StatusOutBtnClick(Sender: TObject);
function ChiSq(x : double; n : integer) : double;
function Norm(z : double): double;
function ix(j, k, nCols : integer): integer;
procedure VarListDblClick(Sender: TObject);
procedure VarListSelectionChange(Sender: TObject; {%H-}User: boolean);
private
{ private declarations }
protected
procedure AdjustConstraints; override;
procedure Compute; override;
procedure UpdateBtnStates; override;
public
procedure Reset; override;
end;
var
CoxRegForm: TCoxRegForm;
implementation
{$R *.lfm}
uses
Math,
Utils;
{ TCoxRegForm }
procedure TCoxRegForm.AdjustConstraints;
begin
inherited;
ParamsPanel.Constraints.MinWidth := Max(
4*CloseBtn.Width + 3*CloseBtn.BorderSpacing.Left,
GroupBox1.Width);
ParamsPanel.Constraints.MinHeight := InBtn.Top + 6*InBtn.Height + 7*OutBtn.BorderSpacing.Top +
VarList.BorderSpacing.Bottom + MaxItsEdit.Height + MaxItsEdit.BorderSpacing.Bottom +
GroupBox1.Height + ButtonBevel.Height + CloseBtn.BorderSpacing.Top + CloseBtn.Height;
end;
procedure TCoxRegForm.BlockListDblClick(Sender: TObject);
var
index: Integer;
begin
index := BlockList.ItemIndex;
if index > -1 then
begin
VarList.Items.Add(BlockList.Items[index]);
BlockList.Items.Delete(index);
UpdateBtnStates;
end;
end;
function TCoxRegForm.ChiSq(x: double; n: integer): double;
var
p, t, a: double;
k: integer;
begin
p := exp(-0.5 * x);
if n mod 2 = 1 then
p := p * sqrt(2 * x / Pi);
k := n;
while K >= 2 do
begin
p := p * x / k;
k := k - 2;
end;
t := p;
a := n;
while t > 0.000001 * p do
begin
a := a + 2;
t := t * x / a;
p := p + t;
end;
Result := (1 - p);
end;
procedure TCoxRegForm.Compute;
var
i, j, k : integer;
indx : integer;
cellstring : string;
outline : string;
nR : integer; // no. independent variables
ColNoSelected : IntDyneVec = nil;
nC : integer; // no. cases
nP : integer; // survival time variable
nS : integer; // survival status variable
zX : double;
v : double;
Eps : double;
iBig : integer;
LLp, LL : double;
LLn : double;
s0 : double;
StatI : double;
Sf : double;
CSq : double; // chi square statistic
prob : double; // probability of chi square
SurvT : DblDyneVec = nil;
Stat : DblDyneVec = nil;
Alpha : DblDyneVec = nil;
a : DblDyneVec = nil;
b : DblDyneVec = nil;
s1 : DblDyneVec = nil;
s2 : DblDyneVec = nil;
s : DblDyneVec = nil;
Av : DblDyneVec = nil;
SD : DblDyneVec = nil;
SE : DblDyneVec = nil;
x : DblDyneVec = nil; // data matrix for independent variables
RowLabels : StrDyneVec = nil;
ColLabels : StrDyneVec;
Lo95 : double;
Hi95 : double;
d : double;
iters : integer;
lReport: TStrings;
begin
if MaxItsEdit.Text = '' then
begin
MaxItsEdit.Setfocus;
MessageDlg('Maximum iterations not specified.', mtError, [mbOK], 0);
exit;
end;
if not TryStrToInt(MaxItsEdit.Text, iters) then
begin
MaxItsEdit.SetFocus;
MessageDlg('Valid number required.', mtError, [mbOK], 0);
exit;
end;
{ get independent item columns }
nR := BlockList.Items.Count;
nC := NoCases;
SetLength(ColNoSelected,nR + 2);
SetLength(RowLabels,nR + 2);
SetLength(ColLabels,nR + 2);
if nR < 1 then
begin
MessageDlg('No independent variables selected.', mtError, [mbOK], 0);
exit;
end;
for i := 1 to nR do
begin
cellstring := BlockList.Items.Strings[i-1];
for j := 1 to NoVariables do
begin
if cellstring = OS3MainFrm.DataGrid.Cells[j,0] then
begin
ColNoSelected[i-1] := j;
RowLabels[i-1] := cellstring;
ColLabels[i-1] := cellstring;
end;
end;
end;
{ get survival time variable column and survival status var. column }
if DepVar.Text = '' then
begin
MessageDlg('No Survival time variable selected.', mtError, [mbOK], 0);
exit;
end;
if StatusEdit.Text = '' then
begin
MessageDlg('No Survival Status variable selected.', mtError, [mbOK], 0);
exit;
end;
nP := nR + 1;
nS := nP + 1;
for j := 1 to NoVariables do
begin
if DepVar.Text = OS3MainFrm.DataGrid.Cells[j,0] then
begin
ColNoSelected[nP-1] := j;
RowLabels[nP-1] := OS3MainFrm.DataGrid.Cells[j,0];
ColLabels[nP-1] := RowLabels[nP-1];
end;
if StatusEdit.Text = OS3MainFrm.DataGrid.Cells[j,0] then
begin
ColNoSelected[nS-1] := j;
RowLabels[nS-1] := OS3MainFrm.DataGrid.Cells[j,0];
ColLabels[nS-1] := RowLabels[nS-1];
end;
end;
SetLength(SurvT,nC + 1);
SetLength(Stat,nC + 1);
SetLength(Alpha,nC + 1);
SetLength(x,(nC + 1) * (nR + 1));
SetLength(b,nC + 1);
SetLength(a,(nR + 1) * (nR + 1));
SetLength(s1,nR + 1);
SetLength(s2,(nR + 1) * (nR + 1));
SetLength(s,nR + 1);
SetLength(Av,nR + 1);
SetLength(SD,nR + 1);
SetLength(SE,nR + 1);
// get data
for i := 0 to nC - 1 do
begin
indx := ix(i,0,nR+1);
X[indx] := 1;
for j := 0 to nR-1 do
begin
indx := ColNoSelected[j];
zX := StrToFloat(Trim(OS3MainFrm.DataGrid.Cells[indx,i+1]));
indx := ix(i,j,nR);
x[indx] := zX;
Av[j] := Av[j] + zX;
SD[j] := SD[j] + (zX * zX);
end;
// get survival time
indx := ColNoSelected[nP-1];
zX := StrToFloat(Trim(OS3MainFrm.DataGrid.Cells[indx,i+1]));
SurvT[i] := zX;
// get survival status
indx := ColNoSelected[nS-1];
zX := StrToFloat(Trim(OS3MainFrm.DataGrid.Cells[indx,i+1]));
Stat[i] := zX;
end; // next case i
// print descriptive statistics
lReport := TStringList.Create;
try
lReport.Add('COX PROPORTIONAL HARARDS SURVIVAL REGRESSION adapted from John C. Pezzullo');
lReport.Add('Java program at http://members.aol.com/johnp71/prophaz.html');
lReport.Add('');
if DescChk.Checked then
begin
lReport.Add('Descriptive Statistics');
lReport.Add('Variable Label Average Std.Dev.');
end;
for j := 0 to nR-1 do
begin
Av[j] := Av[j] / nC;
SD[j] := SD[j] / nC;
SD[j] := sqrt( abs(SD[j] - Av[j] * Av[j]));
if DescChk.Checked then
lReport.Add(' %3d %15s %11.4f %11.4f', [j+1, RowLabels[j], Av[j], SD[j]]);
end;
lReport.Add('');
d := 0.0;
Eps := 1.0 / 1024.0;
for i := 0 to nC-2 do
begin
iBig := i;
for j := i+1 to nC-1 do
if (SurvT[j] - Eps * Stat[j]) > (SurvT[iBig]-Eps * Stat[iBig]) then
iBig := j;
if iBig <> i then
begin
v := SurvT[i];
SurvT[i] := SurvT[iBig];
SurvT[iBig] := v;
v := Stat[i];
Stat[i] := Stat[iBig];
Stat[iBig] := v;
for j := 0 to nR-1 do
begin
v := x[ix(i,j,nR)];
x[ix(i,j,nR)] := x[ix(iBig,j,nR)];
x[ix(iBig,j,nR)] := v;
end;
end;
end;
if Stat[0] > 0 then
Stat[0] := Stat[0] + 2;
for i := 1 to nC-1 do
begin
if (Stat[i] > 0) and ((Stat[i-1] = 0) or (SurvT[i-1] <> SurvT[i])) then
Stat[i] := Stat[i] + 2;
end;
if Stat[nC-1] > 0 then
Stat[nC-1] := Stat[nC-1] + 4;
for i := nC-2 downto 0 do
begin
if (Stat[i] > 0) and ((Stat[i+1] = 0) or (SurvT[i+1] <> Survt[i])) then
Stat[i] := Stat[i] + 4;
end;
for i := 0 to nC-1 do
begin
for j := 0 to nR-1 do
begin
x[ix(i,j,nR)] := (x[ix(i,j,nR)] - Av[j]) / SD[j];
end;
end;
if ItersChk.Checked then
lReport.Add('Iteration History...');
for j := 0 to nR-1 do b[j] := 0;
LLp := 2.0e30;
LL := 1.0e30;
// start iterations
iters := 0;
while (Abs(LLp-LL) > 0.0001) do
begin
iters := iters + 1;
if iters > StrToInt(MaxItsEdit.Text) then break;
LLp := LL;
LL := 0.0;
s0 := 0.0;
for j := 0 to nR-1 do
begin
s1[j] := 0.0;
a[ix(j,nR,nR+1)] := 0.0;
for k := 0 to nR-1 do
begin
s2[ix(j,k,nR)] := 0.0;
a[ix(j,k,nR+1)] := 0.0;
end;
end;
for i := 0 to nC-1 do
begin
Alpha[i] := 1.0;
v := 0.0;
for j := 0 to nR-1 do v := v + b[j] * x[ix(i,j,nR)];
v := exp(v);
s0 := s0 + v;
for j := 0 to nR-1 do
begin
s1[j] := s1[j] + x[ix(i,j,nR)] * v;
for k := 0 to nR-1 do
s2[ix(j,k,nR)] := s2[ix(j,k,nR)] + x[ix(i,j,nR)] * x[ix(i,k,nR)] * v;
end;
StatI := Stat[i];
if (StatI = 2) or (StatI = 3) or (StatI = 6) or (StatI = 7) then
begin
d := 0.0;
for j := 0 to nR-1 do s[j] := 0.0;
end;
if (StatI = 1) or (StatI = 3) or (StatI = 5) or (StatI = 7) then
begin
d := d + 1;
for j := 0 to nR-1 do s[j] := s[j] + x[ix(i,j,nR)];
end;
if (StatI = 4) or (StatI = 5) or (StatI = 6) or (StatI = 7) then
begin
for j := 0 to nR-1 do
begin
LL := LL + s[j] * b[j];
a[ix(j,nR,nR+1)] := a[ix(j,nR,nR+1)] + s[j] - d * s1[j] / s0;
for k := 0 to nR-1 do
begin
a[ix(j,k,nR+1)] := a[ix(j,k,nR+1)] + d * (s2[ix(j,k,nR)] / s0 -
s1[j] * s1[k] / (s0 * s0));
end;
end;
LL := LL - d * Ln(s0);
if d = 1 then Alpha[i] := Power((1.0 - v / s0),(1.0 / v))
else Alpha[i] := exp(-d / s0);
end;
end;
LL := -2.0 * LL;
outline := format('-2 Log Likelihood: %.4f',[LL]);
if iters = 1 then
begin
LLn := LL;
if ItersChk.Checked then
outline := outline + ' (Null Model)';
end;
if ItersChk.Checked then
lReport.Add(outline);
for i := 0 to nR-1 do
begin
v := a[ix(i,i,nR+1)];
a[ix(i,i,nR+1)] := 1.0;
for k := 0 to nR do
a[ix(i,k,nR+1)] := a[ix(i,k,nR+1)] / v;
for j := 0 to nR-1 do
begin
if i <> j then
begin
v := a[ix(j,i,nR+1)];
a[ix(j,i,nR+1)] := 0.0;
for k := 0 to nR do
a[ix(j,k,nR+1)] := a[ix(j,k,nR+1)] - v * a[ix(i,k,nR+1)];
end;
end;
end;
for j := 0 to nR-1 do b[j] := b[j] + a[ix(j,nR,nR+1)];
end;
lReport.Add('Converged');
Csq := LLn - LL;
lReport.Add('');
lReport.Add('Overall Model Fit...');
if Csq > 0.0 then prob := ChiSq(Csq,nR) else prob := 1.0;
lReport.Add('Chi Square: %8.4f', [csq]);
lReport.Add(' with d.f. %8d', [nR]);
lReport.Add(' and probability: %8.4f', [prob]);
lReport.Add('');
lReport.Add('Coefficients, Std Errs, Signif, and Confidence Intervals');
lReport.Add('');
lReport.Add('Var Coeff. StdErr p Lo95% Hi95%');
for j := 0 to nR-1 do
begin
b[j] := b[j] / SD[j];
SE[j] := sqrt(a[ix(j,j,nR+1)]) / SD[j];
prob := Norm(Abs(b[j] / SE[j]));
Lo95 := b[j] - 1.96 * SE[j];
Hi95 := b[j] + 1.96 * SE[j];
lReport.Add('%10s %10.4f %10.4f %8.4f %8.4f %8.4f',
[RowLabels[j], b[j], SE[j], prob, Lo95, Hi95]);
end;
lReport.Add('');
lReport.Add('Risk Ratios and Confidence Intervals');
lReport.Add('');
lReport.Add('Variable Risk Ratio Lo95% Hi95%');
for j := 0 to nR-1 do
lReport.Add('%10s %10.4f %10.4f %10.4f',
[RowLabels[j], exp(b[j]), exp(b[j]-1.96*SE[j]), exp(b[j]+1.96*SE[j])]);
lReport.Add('');
if ProbsChk.Checked then
lReport.Add('Baseline Survivor Function (at predictor means)...');
SF := 1.0;
for i := nC-1 downto 0 do
begin
Sf := Sf * Alpha[i];
if Alpha[i] < 1.0 then
begin
if ProbsChk.Checked then
lReport.Add('%10.4f %10.4f', [SurvT[i], Sf]);
end;
end;
FReportFrame.DisplayReport(lReport);
finally
lReport.Free;
end;
end;
procedure TCoxRegForm.DepInBtnClick(Sender: TObject);
var
index: integer;
begin
index := VarList.ItemIndex;
if (index > -1) and (DepVar.Text = '') then
begin
DepVar.Text := VarList.Items[index];
VarList.Items.Delete(index);
end;
UpdateBtnStates;
end;
procedure TCoxRegForm.DepOutBtnClick(Sender: TObject);
begin
if DepVar.Text <> '' then
begin
VarList.Items.Add(DepVar.Text);
DepVar.Text := '';
end;
UpdateBtnStates;
end;
procedure TCoxRegForm.InBtnClick(Sender: TObject);
var
i: integer;
begin
i := 0;
while i < VarList.Items.Count do
begin
if VarList.Selected[i] then
begin
BlockList.Items.Add(VarList.Items[i]);
VarList.Items.Delete(i);
i := 0;
end else
i := i + 1;
end;
UpdateBtnStates;
end;
function TCoxRegForm.ix(j, k, nCols : integer): integer;
begin
Result := j*nCols + k;
end;
function TCoxRegForm.Norm(z: double): double;
begin
Result := ChiSq(z*z, 1);
end;
procedure TCoxRegForm.OutBtnClick(Sender: TObject);
var
i: integer;
begin
i := 0;
while i < BlockList.Items.Count do
begin
if BlockList.Selected[i] then
begin
VarList.Items.Add(BlockList.Items[i]);
BlockList.Items.Delete(i);
i := 0;
end else
i := i + 1;
UpdateBtnStates;
end;
end;
procedure TCoxRegForm.Reset;
var
i: integer;
begin
inherited;
BlockList.Clear;
VarList.Clear;
for i := 1 to NoVariables do
VarList.Items.Add(OS3MainFrm.DataGrid.Cells[i,0]);
ProbsChk.Checked := true;
DescChk.Checked := true;
DepVar.Text := '';
StatusEdit.Text := '';
MaxItsEdit.Text := '20';
end;
procedure TCoxRegForm.StatusInBtnClick(Sender: TObject);
var
index: integer;
begin
index := VarList.ItemIndex;
if (index > -1) and (StatusEdit.Text = '') then
begin
StatusEdit.Text := VarList.Items[index];
VarList.Items.Delete(index);
end;
UpdateBtnStates;
end;
procedure TCoxRegForm.StatusOutBtnClick(Sender: TObject);
begin
if (StatusEdit.Text <> '') then
begin
VarList.Items.Add(StatusEdit.Text);
StatusEdit.Text := '';
end;
UpdateBtnStates;
end;
procedure TCoxRegForm.UpdateBtnStates;
var
lSelected: Boolean;
begin
inherited;
lSelected := AnySelected(VarList);
InBtn.Enabled := lSelected;
DepInBtn.Enabled := lSelected and (DepVar.Text = '');
StatusInBtn.Enabled := lSelected and (StatusEdit.Text = '');
OutBtn.Enabled := AnySelected(BlockList);
DepOutBtn.Enabled := DepVar.Text <> '';
StatusOutBtn.Enabled := StatusEdit.Text <> '';
end;
procedure TCoxRegForm.VarListDblClick(Sender: TObject);
var
index: Integer;
begin
index := VarList.ItemIndex;
if index > -1 then
begin
BlockList.Items.Add(VarList.Items[index]);
VarList.Items.Delete(index);
UpdateBtnStates;
end;
end;
procedure TCoxRegForm.VarListSelectionChange(Sender: TObject; User: boolean);
begin
UpdateBtnStates;
end;
end.