lazarus-ccr/applications/lazstats/source/forms/analysis/descriptive/crosstabunit.pas

// Use file "twoway.laz" for testing

unit CrossTabUnit;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs,
  StdCtrls, Buttons, ExtCtrls, ComCtrls,
  Globals, MainUnit, DataProcs, MatrixLib, ContextHelpUnit,
  BasicStatsFormUnit, ReportFrameUnit;

type

  { TCrossTabFrm }

  TCrossTabFrm = class(TBasicStatsForm)
    ComputeBtn: TButton;
    PageControl: TPageControl;
    ParamsPanel: TPanel;
    ParamsSplitter: TSplitter;
    ReportPage: TTabSheet;
    VertCenterBevel: TBevel;
    Bevel2: TBevel;
    HelpBtn: TButton;
    InBtn: TBitBtn;
    OutBtn: TBitBtn;
    ResetBtn: TButton;
    CloseBtn: TButton;
    Label1: TLabel;
    Label2: TLabel;
    VarList: TListBox;
    SelList: TListBox;
    procedure CloseBtnClick(Sender: TObject);
    procedure ComputeBtnClick(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure HelpBtnClick(Sender: TObject);
    procedure InBtnClick(Sender: TObject);
    procedure OutBtnClick(Sender: TObject);
    procedure ResetBtnClick(Sender: TObject);
    procedure SelListDblClick(Sender: TObject);
    procedure VarListDblClick(Sender: TObject);
    procedure VarListSelectionChange(Sender: TObject; {%H-}User: boolean);

  private
    FReportFrame: TReportFrame;
    FAutosized: Boolean;
    procedure Prepare(out AVarList, AColNoSelected: IntDyneVec);
    procedure UpdateBtnStates;

  public
    procedure Reset; override;
  end; 

var
  CrossTabFrm: TCrossTabFrm;


implementation

{$R *.lfm}

uses
  Math, Grids,
  Utils, DictionaryUnit, GridProcs;


{ TCrossTabCalculator }

type
  TCrossTabCalculator = class
  private
    FReport: TStrings;
    FVarList: IntDyneVec;
    FDataGrid: TStringGrid;
    FColNoSelected: IntDyneVec;

    grandsum, sum, index: integer;
    no_in_list, length_array: integer;
    min_value, levels, displace, subscript: IntDyneVec;
    freq: IntDyneVec;
    outgrid: DblDyneMat;
    NoSelected: integer;

  protected
    procedure BreakDown;
    procedure GetLevels;
    function IndexPosition(x: IntDyneVec): integer;
    procedure Tabulate;

  public
    procedure Execute(AReport: TStrings; ADataGrid: TStringGrid;
      AVarList, AColNoSelected: IntDyneVec);

  end;


procedure TCrossTabCalculator.BreakDown;
var
  i, j, row, col, bigmax: integer;
  ptr1, ptr2: Integer;
  outline: string;
  value: string;
  title: String;
  rowLabels: StrDyneVec = nil;
  colLabels: StrDyneVec = nil;
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 := FDataGrid.Cells[FVarList[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;

  FReport.Add('');
  FReport.Add('FREQUENCIES BY LEVEL:');
  FReport.Add('');

  sum := 0;
  col := 1;
  row := 1;

  while true do
  begin
    index := IndexPosition(subscript);
    outline := 'For cell levels: ';
    for i := 1 to no_in_list do
    begin
      j := FVarList[i-1];
      value := Format('%s:%3d  ',[FDataGrid.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]]);
    FReport.Add(outline);

    subscript[ptr2-1] := subscript[ptr2-1] + 1;
    col := col + 1;
    if subscript[ptr2-1] <= levels[ptr2-1] then
      continue;

    FReport.Add('Sum across levels: %3d', [sum]);
    FReport.Add('');

    grandsum := grandsum + sum;
    sum := 0;
    row := row + 1;

    if ptr1 < 1 then
      break;

    subscript[ptr1-1] := subscript[ptr1-1] + 1;
    if subscript[ptr1-1] > levels[ptr1-1] then
    begin
      repeat
        ptr1 := ptr1 - 1;
        if ptr1 < 1 then
          break;
      until subscript[ptr1-1] < levels[ptr1-1];
      if ptr1 < 1 then
        break;
      subscript[ptr1-1] := subscript[ptr1-1] + 1;
    end;

    for i := ptr1 + 1 to no_in_list do
      subscript[i-1] := 1;
    ptr1 := no_in_list - 1;
    col := 1;

  end;

  title := 'CELL FREQUENCIES BY LEVELS';
  for i := 1 to row - 1 do
  begin
    value := Format('Block %d',[i]);
    rowlabels[i-1] := value;
  end;

  FReport.Add('');
  MatPrint(outgrid, row-1, Levels[no_in_list-1], title, rowlabels, collabels, NoCases, FReport);
end;


procedure TCrossTabCalculator.Execute(AReport: TStrings; ADataGrid: TStringGrid;
  AVarList, AColNoSelected: IntDyneVec);
begin
  FReport := AReport;
  FDataGrid := ADataGrid;
  FVarList := AVarList;

  no_in_list := Length(FVarList);
  SetLength(min_value, no_in_list);
  SetLength(levels, no_in_list);
  SetLength(displace, no_in_list);
  SetLength(subscript, no_in_list);

  FColNoSelected := AColNoSelected;
  NoSelected := Length(FColNoSelected);

  GetLevels;
  Tabulate;
  BreakDown;

  FReport.Add('');
  FReport.Add('Grand sum across all categories: %d', [grandsum]);
end;

procedure TCrossTabCalculator.GetLevels;
var
  i, j, k: integer;
  value: double;
  max_value: IntDyneVec = nil;
begin
  SetLength(max_value, no_in_list);
  for i := 1 to no_in_list do
  begin
    j := FVarList[i-1];
    if not GoodRecord(FDataGrid, 1, FColNoSelected) then continue;
    value := StrToFloat(FDataGrid.Cells[j, 1]);
    min_value[i-1] := round(value);
    max_value[i-1] := round(value);
    for k := 2 to NoCases do
    begin
      if not GoodRecord(FDataGrid, k, FColNoSelected) then continue;
      value := StrToFloat(FDataGrid.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 := FVarList[i-1];
    levels[i-1] := max_value[i-1] - min_value[i-1] + 1;
    FReport.Add('%-10s   min %3d, max %3d, number of levels %3d', [
      FDataGrid.Cells[j,0]+':', min_value[i-1], max_value[i-1], levels[i-1]
    ]);
  end;
  FReport.Add('');

  displace[no_in_list-1] := 1;
  if no_in_list > 1 then
    for i := (no_in_list - 1) downto 1 do
      displace[i-1] := levels[i] * displace[i];
end;


function TCrossTabCalculator.IndexPosition(x: IntDyneVec): integer;
var
  i: integer;
begin
  Result := x[no_in_list-1];
  if no_in_list > 1 then
  begin
    for i := 1 to no_in_list - 1 do
      Result := Result + (x[i-1] -1) * displace[i-1];
  end;
end;


procedure TCrossTabCalculator.Tabulate;
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 NoCases do
  begin
    if IsFiltered(FDataGrid, i) then
      continue;
    for j := 1 to no_in_list do
    begin
      if not GoodRecord(FDataGrid, i, FColNoSelected) then continue;
      k := FVarList[j-1];
      value := StrToFloat(FDataGrid.Cells[k,i]);
      x := round(value);
      x := x - min_value[j-1] + 1;
      subscript[j-1] := x;
    end;
    j := IndexPosition(subscript);

    if (j < 1) or (j > length_array) then
      continue
    else
      freq[j] := freq[j] + 1;
  end;
end;


{ TCrossTabFrm }

procedure TCrossTabFrm.CloseBtnClick(Sender: TObject);
begin
  Close;
end;


procedure TCrossTabFrm.ComputeBtnClick(Sender: TObject);
var
  lReport: TStringList;
  calculator: TCrossTabCalculator;
  var_list: IntDyneVec = nil;
  colNoSelected: IntDyneVec = nil;
begin
  if SelList.Items.Count = 0 then
  begin
    ErrorMsg('No variables selected for analysis.');
    exit;
  end;

  lReport := TStringList.Create;
  try
    lReport.Add('CROSSTAB RESULTS');
    lReport.Add('');
    lReport.Add('Analyzed data is from file ' + OS3MainFrm.FileNameEdit.Text);
    lReport.Add('');

    calculator := TCrossTabCalculator.Create;
    try
      Prepare(var_list, colNoSelected);
      calculator.Execute(lReport, OS3MainFrm.DataGrid, var_list, colNoSelected);
      FReportFrame.DisplayReport(lReport);
    finally
      calculator.Free;
    end;
  finally
    lReport.Free;
  end;
end;


procedure TCrossTabFrm.FormActivate(Sender: TObject);
var
  w: Integer;
begin
   if FAutoSized then
     exit;

   w := MaxValue([HelpBtn.Width, ResetBtn.Width, ComputeBtn.Width, CloseBtn.Width]);
   HelpBtn.Constraints.MinWidth := w;
   ResetBtn.Constraints.MinWidth := w;
   ComputeBtn.Constraints.MinWidth := w;
   CloseBtn.Constraints.MinWidth := w;

   ParamsPanel.Constraints.MinWidth := Max(
     4*w + 3*CloseBtn.BorderSpacing.Left,
     Max(Label1.Width, Label2.Width) + InBtn.Width + VarList.BorderSpacing.Right * 2
   );
   ParamsPanel.Constraints.MinHeight := 200;

   Constraints.MinWidth := ParamsPanel.Constraints.MinWidth + 300;;
   Constraints.MinHeight := ParamsPanel.Constraints.MinHeight + 2*ParamsPanel.BorderSpacing.Top;
   if Width < Constraints.MinWidth then Width := 1;  // enforce constraints
   if Height < Constraints.MinHeight then Height := 1;

   Position := poDesigned;
   FAutoSized := true;
end;


procedure TCrossTabFrm.FormCreate(Sender: TObject);
begin
  Assert(OS3MainFrm <> nil);

  InitForm(self);

  FReportFrame := TReportFrame.Create(self);
  with FReportFrame do
  begin
    Parent := ReportPage;
    Align := alClient;
  end;

  Reset;
end;


procedure TCrossTabFrm.HelpBtnClick(Sender: TObject);
begin
  if ContextHelpForm = nil then
    Application.CreateForm(TContextHelpForm, ContextHelpForm);
  ContextHelpForm.HelpMessage((Sender as TButton).Tag);
end;


procedure TCrossTabFrm.InBtnClick(Sender: TObject);
var
  i: integer;
begin
  i := 0;
  while i < VarList.Items.Count do
  begin
    if VarList.Selected[i] then
    begin
      SelList.Items.Add(VarList.Items[i]);
      VarList.Items.Delete(i);
      i := 0;
    end else
      inc(i);
  end;
  UpdateBtnStates;
end;


procedure TCrossTabFrm.OutBtnClick(Sender: TObject);
var
  i: integer;
begin
  i := 0;
  while i < SelList.Items.Count do
  begin
    if SelList.Selected[i] then
    begin
      VarList.Items.Add(SelList.Items[i]);
      SelList.Items.Delete(i);
      i := 0;
    end else
      inc(i);
  end;
  UpdateBtnStates;
end;


procedure TCrossTabFrm.Prepare(out AVarlist, AColNoSelected: IntDyneVec);
var
  i, j: Integer;
  noSelected: Integer;
  cellValue: String;
begin
  AVarList := nil;       // Silence the compiler
  AColNoSelected := nil;

  SetLength(AVarList, SelList.Count);
  SetLength(AColNoSelected, SelList.Count);

  noSelected := 0;
  for i := 0 to SelList.Items.Count-1 do
  begin
    for j := 1 to NoVariables do
    begin
      cellvalue := OS3MainFrm.DataGrid.Cells[j, 0];
      if cellvalue = SelList.Items[i] then
      begin
        AVarList[i] := j;
        AColNoSelected[i] := j;
        inc(noSelected);
        break;
      end;
    end;
  end;

  SetLength(AVarList, noSelected);
  Setlength(AColNoSelected, noSelected);
end;


procedure TCrossTabFrm.Reset;
var
  i: integer;
begin
  VarList.Clear;
  SelList.Clear;
  for i := 1 to NoVariables do
    VarList.Items.Add(OS3MainFrm.DataGrid.Cells[i,0]);
  UpdateBtnStates;
  FReportFrame.Clear;
end;


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


procedure TCrossTabFrm.SelListDblClick(Sender: TObject);
var
  index: Integer;
begin
  index := SelList.ItemIndex;
  if index > -1 then
  begin
    VarList.Items.Add(Sellist.Items[index]);
    SelList.Items.Delete(index);
    UpdateBtnStates;
  end;
end;


procedure TCrossTabFrm.UpdateBtnStates;
var
  lSelected: Boolean;
  i: Integer;
begin
  lSelected := false;
  for i := 0 to VarList.Items.Count-1 do
    if VarList.Selected[i] then
    begin
      lSelected := true;
      break;
    end;
  InBtn.Enabled := lSelected;

  lSelected := false;
  for i := 0 to SelList.Items.Count-1 do
    if SelList.Selected[i] then
    begin
      lSelected := true;
      break;
    end;
  OutBtn.Enabled := lSelected;

  FReportFrame.UpdateBtnStates;
end;


procedure TCrossTabFrm.VarListDblClick(Sender: TObject);
var
  index: Integer;
begin
  index := VarList.ItemIndex;
  if index > -1 then
  begin
    SelList.Items.Add(VarList.Items[index]);
    Varlist.Items.Delete(index);
    UpdateBtnStates;
  end;
end;


procedure TCrossTabFrm.VarListSelectionChange(Sender: TObject; User: boolean);
begin
  UpdateBtnStates;
end;


end.