lazarus-ccr/applications/lazstats/source_orig/crosstabunit.pas

unit CrossTabUnit;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
  StdCtrls, Buttons, Globals, OutPutUnit, MainUnit, DataProcs, FunctionsLib,
  MatrixLib, contexthelpunit;

type

  { TCrossTabFrm }

  TCrossTabFrm = class(TForm)
    HelpBtn: TButton;
    InBtn: TBitBtn;
    OutBtn: TBitBtn;
    ResetBtn: TButton;
    CancelBtn: TButton;
    OKBtn: TButton;
    Label1: TLabel;
    Label2: TLabel;
    VarList: TListBox;
    ListBox1: TListBox;
    procedure CancelBtnClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure HelpBtnClick(Sender: TObject);
    procedure InBtnClick(Sender: TObject);
    procedure OKBtnClick(Sender: TObject);
    procedure OutBtnClick(Sender: TObject);
    procedure ResetBtnClick(Sender: TObject);
  private
    { private declarations }
    grandsum, sum, index : integer;
    no_in_list, length_array, ptr1, ptr2 : integer ;
    var_list, min_value, max_value, levels, displace, subscript : IntDyneVec;
    freq : IntDyneVec;
    outgrid : DblDyneMat;
    rowlabels : StrDyneVec;
    colLabels : StrDyneVec;
    ColNoSelected : IntDyneVec;
    NoSelected : integer;
    NV, NC : integer;

    procedure INITIALIZEIT(Sender: TObject);
    procedure GET_Levels(Sender: TObject);
    function INDEX_POSITION( x : IntDyneVec; Sender: TObject ) : integer;
    Procedure TABULATE(Sender : TObject);
    procedure BREAKDOWN(Sender : TObject);

  public
    { public declarations }
  end; 

var
  CrossTabFrm: TCrossTabFrm;

implementation

{ TCrossTabFrm }

procedure TCrossTabFrm.ResetBtnClick(Sender: TObject);
var
   i : integer;

begin
     VarList.Clear;
     ListBox1.Clear;
     OutBtn.Enabled := false;
     InBtn.Enabled := true;
     NV := NoVariables;
     NC := NoCases;
     for i := 1 to NV do
          VarList.Items.Add(OS3MainFrm.DataGrid.Cells[i,0]);
end;



procedure TCrossTabFrm.FormShow(Sender: TObject);
begin
     ResetBtnClick(self);
end;

procedure TCrossTabFrm.HelpBtnClick(Sender: TObject);
begin
  ContextHelpForm.HelpMessage((Sender as TButton).tag);
end;

procedure TCrossTabFrm.InBtnClick(Sender: TObject);
var
   index2, i : integer;

begin
     index2 := VarList.Items.Count;
     i := 0;
     while i < index2 do
     begin
         if (VarList.Selected[i]) then
         begin
            ListBox1.Items.Add(VarList.Items.Strings[i]);
            VarList.Items.Delete(i);
            index2 := index2 - 1;
            i := 0;
         end
         else i := i + 1;
     end;
     OutBtn.Enabled := true;
end;

procedure TCrossTabFrm.OKBtnClick(Sender: TObject);
label CleanUp;
var
   cellvalue : string;
   i, j : integer;
   outline : string;

begin
     SetLength(var_list,NV);
     SetLength(min_value,NV);
     SetLength(max_value,NV);
     SetLength(levels,NC);
     SetLength(displace,NC);
     SetLength(subscript,NC);
     SetLength(ColNoSelected,NV);

     OutPutFrm.RichEdit.Clear;
//     OutPutFrm.RichEdit.ParaGraph.Alignment := taLeftJustify;
     OutPutFrm.RichEdit.Lines.Add('CROSSTAB RESULTS');
     OutPutFrm.RichEdit.Lines.Add('');
     outline :=  '       Analyzed data is from file : ';
     outline := outline + OS3MainFrm.FileNameEdit.Text;
     OutPutFrm.RichEdit.Lines.Add(outline);
     OutPutFrm.RichEdit.Lines.Add('');
     INITIALIZE(self);
     if ListBox1.Items.Count = 0 then
     begin
   //       Application.MessageBox('No variables selected for analysis.','ERROR!',MB_OK);
          goto CleanUp;
     end;

     NoSelected := 0;
     for i := 0 to ListBox1.Items.Count-1 do
     begin
          for j := 1 to NV do
          begin
               cellvalue := OS3MainFrm.DataGrid.Cells[j,0];
               if cellvalue = ListBox1.Items.Strings[i] then
               begin
                    var_list[i] := j;
                    ColNoSelected[i] := j;
                    NoSelected := NoSelected + 1;
                    break;
               end;
          end;
     end;
     no_in_list := ListBox1.Items.Count;
     GET_LEVELS(self);
     TABULATE(self);
     BREAKDOWN(self);
     OutPutFrm.RichEdit.Lines.Add('');
     cellvalue := format('Grand sum accross all categories = %3d',[grandsum]);
     OutPutFrm.RichEdit.Lines.Add(cellvalue);
     OutPutFrm.ShowModal;

CleanUp:
     ColNoSelected := nil;
     freq := nil;
     collabels := nil;
     rowlabels := nil;
     outgrid := nil;
     subscript := nil;
     displace := nil;
     levels := nil;
     max_value := nil;
     min_value := nil;
     var_list := nil;
     CrossTabFrm.Hide;
end;

procedure TCrossTabFrm.OutBtnClick(Sender: TObject);
var
   index2: integer;

begin
   index2 := ListBox1.ItemIndex;
   VarList.Items.Add(ListBox1.Items.Strings[index2]);
   ListBox1.Items.Delete(index2);
   InBtn.Enabled := true;
   if ListBox1.Items.Count = 0 then OutBtn.Enabled := false;
end;

procedure TCrossTabFrm.CancelBtnClick(Sender: TObject);
begin
     CrossTabFrm.Hide;
end;

procedure TCrossTabFrm.INITIALIZEIT(Sender: TObject);
var
   i : integer;

begin
     no_in_list := 0;
     for i := 1 to NV do
     begin
          var_list[i-1] := 0;
          min_value[i-1] := 0;
          max_value[i-1] := 0;
          levels[i-1] := 0;
          displace[i-1] := 0;
          subscript[i-1] := 0;
     end;
     index := 0;
     length_array := 0;
     grandsum := 0;
end; { initialize procedure }
//-----------------------------------------------------------------------

procedure TCrossTabFrm.GET_Levels(Sender: TObject);
var
   i, j, k : integer;
   value : double;
   outline : string;

begin
     for i := 1 to no_in_list do
     begin
          j := var_list[i-1];
          if Not GoodRecord(1,NoSelected,ColNoSelected) then continue;
          value := StrToFloat(OS3MainFrm.DataGrid.Cells[j,1]);
          min_value[i-1] := round(value);
          max_value[i-1] := round(value);
          for k := 2 to NC do
          begin
               if Not GoodRecord(k,NoSelected,ColNoSelected) then continue;
               value := StrToFloat(OS3MainFrm.DataGrid.Cells[j,k]);
               if value < min_value[i-1] then min_value[i-1] :=
                    round(value);
               if value > max_value[i-1] then max_value[i-1] :=
                    round(value);
          end;
     end;
     for i := 1 to no_in_list do
     begin
          j := var_list[i-1];
          levels[i-1] := max_value[i-1] - min_value[i-1] + 1;
          outline := format('%s min.=%3d, max.=%3d, no. levels = %3d',
             [OS3MainFrm.DataGrid.Cells[j,0],min_value[i-1],max_value[i-1],levels[i-1]]);
          OutPutFrm.RichEdit.Lines.Add(outline);
     end;
     OutPutFrm.RichEdit.Lines.Add('');
     displace[no_in_list-1] := 1;
     if no_in_list > 1 then
     begin
     for i := (no_in_list - 1) downto 1 do
              displace[i-1] := levels[i] * displace[i];
     end;
end;
//-----------------------------------------------------------------------
function TCrossTabFrm.INDEX_POSITION( x : IntDyneVec; Sender: TObject ) : integer;

var index2 : integer;
    i : integer;

begin
     index2 := x[no_in_list-1];
     if no_in_list > 1 then
     begin
        for i := 1 to no_in_list - 1 do
             index2 := index2 + (x[i-1] -1) * displace[i-1];
     end;
     index_position := index2;
end;  { function INDEX_POSITION }
//------------------------------------------------------------------------
Procedure TCrossTabFrm.TABULATE(Sender : TObject);
var
   i, j, k : integer;
   value : double;
   x : integer;
begin
     length_array := 1;
     for i := 1 to no_in_list do length_array := length_array * levels[i-1];
     SetLength(freq,length_array+1);
     for i := 0 to length_array do freq[i] := 0;
     for i := 1 to NC do
     begin
          if IsFiltered(i) then continue;
          for j := 1 to no_in_list do
          begin
               if Not GoodRecord(i,NoSelected,ColNoSelected) then continue;
               k := var_list[j-1];
               value := StrToFloat(OS3MainFrm.DataGrid.Cells[k,i]);
               x := round(value);
               x := x - min_value[j-1] + 1;
               subscript[j-1] := x;
          end;
          j := index_position(subscript,self);

          if (j < 1) or (j > length_array) then
          begin
//               Application.MessageBox('subscript out of range.','ERROR!',MB_OK);
               continue;
          end
          else  freq[j] := freq[j] + 1;
     end;
end; { procedure TABULATE }
//---------------------------------------------------------------------
procedure TCrossTabFrm.BREAKDOWN(Sender : TObject);

label 1,2,3,4, printgrid;
var
   i, j, row, col, bigmax : integer;
   outline : string;
   value : string;
   title : String;
begin
     bigmax := -1;
     for i := 0 to no_in_list-1 do
         if Levels[i] > bigmax then bigmax := Levels[i];
     SetLength(colLabels,bigmax);
     SetLength(outgrid,length_array,bigmax);
     SetLength(rowlabels,length_array);
     outline := OS3MainFrm.DataGrid.Cells[var_list[no_in_list-1],0];
     for col := 1 to Levels[no_in_list-1] do
         collabels[col-1] := outline + format(':%3d',[min_value[no_in_list-1] + col - 1]);
     for row := 1 to length_array do rowlabels[row-1] := '';
     ptr1 := no_in_list - 1;
     ptr2 := no_in_list;
     for i := 1 to no_in_list do subscript[i-1] := 1;
     OutPutFrm.RichEdit.Lines.Add('FREQUENCIES BY LEVEL:');
     sum := 0;
     col := 1;
     row := 1;
 1:  index := index_position(subscript,self);
     outline := 'For cell levels: ';
     for i := 1 to no_in_list do
     begin
          j := var_list[i-1];
          value := format('%s:%3d  ',[OS3MainFrm.DataGrid.Cells[j,0],
                   min_value[i-1] + subscript[i-1] - 1]);
          outline := outline + value;
     end;
     sum := sum + freq[index];
     outgrid[row-1,col-1] := freq[index];
     outline := outline + format(' Frequency = %3d',[freq[index]]);
     OutPutFrm.RichEdit.Lines.Add(outline);
     subscript[ptr2-1] := subscript[ptr2-1] + 1;
     col := col + 1;
     IF subscript[ptr2-1] <= levels[ptr2-1] then goto 1;
     outline := format('Sum accross levels = %3d',[sum]);
     OutPutFrm.RichEdit.Lines.Add(outline);
     OutPutFrm.RichEdit.Lines.Add('');
     OutPutFrm.RichEdit.Lines.Add('');
     grandsum := grandsum + sum;
     sum := 0;
     row := row + 1;
 2:  if ptr1 < 1 then goto printgrid;
     subscript[ptr1-1] := subscript[ptr1-1] + 1;
     if subscript[ptr1-1] <= levels[ptr1-1] then  goto 4;
 3:  ptr1 := ptr1 - 1;
     if ptr1 < 1 then goto printgrid;
     if subscript[ptr1-1] >= levels[ptr1-1] then goto 3;
     subscript[ptr1-1] := subscript[ptr1-1] + 1;
 4:  for i := ptr1 + 1 to no_in_list do subscript[i-1] := 1;
     ptr1 := no_in_list - 1;
     col := 1;
     goto 1;

printgrid:
     title := 'Cell Frequencies by Levels';
     for i := 1 to row - 1 do
     begin
          value := format('Block %d',[i]);
          rowlabels[i-1] := value;
     end;
     MAT_PRINT(outgrid,row-1,Levels[no_in_list-1],title,rowlabels,collabels,NC);

end; { Procedure BREAKDOWN }

initialization
  {$I crosstabunit.lrs}

end.