suivant: Bibliographie
monter: Code source
précédent: Définitions et outils nécessaires
Table des matières
unit repartition;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Db, DBTables, Grids, DBGrids, Menus, StdCtrls, DbiProcs, DbiTypes, DbiErrs,
matrix, repartition_utils, ExtCtrls, CheckLst;
type
TForm3 = class(TForm)
MainMenu1: TMainMenu;
Fichiers1: TMenuItem;
Ouvrir1: TMenuItem;
N1: TMenuItem;
Quitter1: TMenuItem;
echantillon: TTable;
DataSource1: TDataSource;
DBGrid1: TDBGrid;
OpenDialog1: TOpenDialog;
db: TDatabase;
ComboBox1: TComboBox;
Bevel1: TBevel;
Label1: TLabel;
Edit1: TEdit;
Label2: TLabel;
Edit2: TEdit;
Bevel2: TBevel;
Bevel3: TBevel;
Bevel4: TBevel;
Bevel5: TBevel;
Bevel6: TBevel;
Bevel7: TBevel;
mllist: TListBox;
vplist: TListBox;
tclist: TListBox;
vp: TRadioButton;
tc: TRadioButton;
ml: TRadioButton;
Button1: TButton;
Button2: TButton;
CheckListBox1: TCheckListBox;
Parametres1: TMenuItem;
Estimation1: TMenuItem;
parametrespardfaut1: TMenuItem;
Afficherteta1: TMenuItem;
procedure Ouvrir1Click(Sender: TObject);
procedure ComboBox1Change(Sender: TObject);
procedure Quitter1Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Estimation1Click(Sender: TObject);
procedure parametrespardfaut1Click(Sender: TObject);
procedure Afficherteta1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form3: TForm3;
function maximisation : double;
implementation
{$R *.DFM}
//******************************************************************************
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
//ouverture de la base et choix de la table.
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
procedure fDbiOpenTableList(hTmpDb: hDBidb; TableList: TStrings);
var
hCursor : hDBICur;
ListDesc : TBLBaseDesc;
begin
Check(DbiOpenTableList(hTmpDb, False, False, '*.mdb', hCursor));
TableList.Clear;
while (DbiGetNextRecord(hCursor, dbiNOLOCK, @ListDesc, nil) = dbiErr_None) do
TableList.Add(ListDesc.szName);
end;
//------------------------------------------------------------------------------
procedure TForm3.Ouvrir1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
begin
//definition de l'Alias pour la base access
db.DatabaseName:=caption;
db.drivername:='MSACCESS';
db.params.clear;
db.params.add('LANGDRIVER=Access General');
db.params.add('DATABASE NAME='+OpenDialog1.FileName);
db.params.add('OPEN MODE=READ/WRITE');
db.params.add('SYSTEM DATABASE=');
db.params.add('PASSWORD=');
db.Connected:=True;
echantillon.databasename:=caption;
ComboBox1.Text:='Choisir une table';
fDbiOpenTableList(db.handle, ComboBox1.Items);
end;
end;
//------------------------------------------------------------------------------
procedure TForm3.ComboBox1Change(Sender: TObject);
var
i : integer;
begin
echantillon.Active:=False;
echantillon.TableName:=ComboBox1.Text;
echantillon.Active:=True;
Edit1.Text:=Inttostr(echantillon.RecordCount);
Edit2.Text:=IntToStr(echantillon.FieldCount);
CheckListBox1.Items.Clear;
for i := 1 to echantillon.FieldCount do
CheckListBox1.Items.Add(echantillon.Fields[i-1].FullName);
end;
//------------------------------------------------------------------------------
procedure TForm3.Quitter1Click(Sender: TObject);
begin
Edit1.Text:='';
Edit2.Text:='';
ComboBox1.text:='';
CheckListBox1.Items.clear;
ComboBox1.items.Clear;
tclist.items.clear;
mllist.items.clear;
vplist.items.clear;
echantillon.Active:=False;
db.Connected:=False;
Application.Terminate;
end;
//------------------------------------------------------------------------------
procedure TForm3.Button1Click(Sender: TObject);
begin
if (vp.Checked and (checklistbox1.itemindex<>-1))then
begin
vplist.Items.add(CheckListBox1.Items.Strings[CheckListBox1.itemindex]);
end;
if (tc.Checked and (checklistbox1.itemindex<>-1))then
begin
tclist.Items.add(CheckListBox1.Items.Strings[CheckListBox1.itemindex]);
end;
if (ml.Checked and (checklistbox1.itemindex<>-1))then
begin
mllist.Items.add(CheckListBox1.Items.Strings[CheckListBox1.itemindex]);
end;
end;
//------------------------------------------------------------------------------
procedure TForm3.Button2Click(Sender: TObject);
begin
if ((vp.Checked) and (vplist.itemindex<>-1)) then
begin
vplist.Items.Delete(vplist.ItemIndex);
end;
if ((tc.Checked) and (tclist.itemindex<>-1)) then
begin
tclist.Items.Delete(tclist.ItemIndex);
end;
if ((ml.Checked) and (mllist.itemindex<>-1)) then
begin
mllist.Items.Delete(mllist.ItemIndex);
end;
end;
{******************************************************************************
* *
* *
* estimation des parametres du modele *
* *
* *
******************************************************************************}
function maximisation : double;
var
epsilon, delta : double;
a, b, c, d, e : double;
fc, fd, fe : double;
begin
epsilon:=0.001;
a:=-0.1; b:=0.1;c:=0;
delta:=abs(a-b);
while delta>epsilon do
begin
c:=(a+b)/2;
d:=(a+c)/2;
e:=(c+b)/2;
copie(mk, teta_temp);
fois(c, teta_temp);
plus(teta_temp, teta, teta_temp);
fc:=f(teta_temp);
copie(mk, teta_temp);
fois(d, teta_temp);
plus(teta_temp, teta, teta_temp);
fd:=f(teta_temp);
copie(mk, teta_temp);
fois(e, teta_temp);
plus(teta_temp, teta, teta_temp);
fe:=f(teta_temp);
if (fd>fc) then b:=c
else if (fc>fe) then a:=c
else
begin
a:=d;
b:=e;
end;
delta:=abs(a-b);
end;
maximisation:=c;
end;
//------------------------------------------------------------------------------
procedure TForm3.Estimation1Click(Sender: TObject);
var
i,j,k,l : integer;
rep : string;
lambda : double;
beta : double;
norme_gk, norme_teta : double;
begin
//formatage de la variable *modalites*
reallocmem(modalites,CheckListBox1.items.count*sizeof(taille_modalite));
//pour les champ a modalite on cherche le nombre de modalites differentes
//manuellement
if MessageDlg('Voulez vous entrer les renseignements sur les modalites manellement ? (conseillé)',
mtConfirmation, [mbYes, mbNo], 0) = mrYes then
begin
for i := 1 to CheckListBox1.Items.Count do
begin
if CheckListBox1.Checked[i-1] then
begin
rep:=InputBox('Entrez le nombre de modalités :',
'pour la variable correspondant au champ : '+echantillon.Fields[i-1].FullName,'1');
modalites^[i]:=strtoint(rep);
end
else modalites^[i]:=1;
end;
end
//ou brutalement
else
begin
for i := 1 to CheckListBox1.Items.Count do modalites^[i]:=1;
echantillon.First;
for j := 1 to echantillon.RecordCount do
begin
for i := 1 to CheckListBox1.Items.Count do
begin
if CheckListBox1.Checked[i-1] then
begin
if echantillon.fields[i-1].Value>modalites^[i] then
begin
modalites^[i]:=echantillon.fields[i-1].Value;
end;
end;
end;
echantillon.Next;
end;
end;
//formatage de la variable *teta*
nteta_vp:=1;
nteta_tc:=1;
nteta_ml:=0;
for i := 1 to vplist.Items.Count do
begin
for j := 1 to CheckListBox1.Items.Count do
begin
if CheckListBox1.Items.strings[j-1]=vplist.Items.strings[i-1] then
begin
if CheckListBox1.Checked[j-1]
then nteta_vp:=nteta_vp+modalites[j]
else inc(nteta_vp);
end;
end;
end;
for i := 1 to tclist.Items.Count do
begin
for j := 1 to CheckListBox1.Items.Count do
begin
if CheckListBox1.Items.strings[j-1]=tclist.Items.strings[i-1] then
begin
if CheckListBox1.Checked[j-1]
then nteta_tc:=nteta_tc+modalites[j]
else inc(nteta_tc);
end;
end;
end;
for i := 1 to mllist.Items.Count do
begin
for j := 1 to CheckListBox1.Items.Count do
begin
if CheckListBox1.Items.strings[j-1]=mllist.Items.strings[i-1] then
begin
if CheckListBox1.Checked[j-1]
then nteta_ml:=nteta_ml+modalites[j]
else inc(nteta_ml);
end;
end;
end;
nteta:=nteta_vp+nteta_tc+nteta_ml;
reallocmem(teta,nteta*sizeof(cellule));
//on initialise la variable teta
teta^[1].place:=0;
teta^[1].utilite:=1;
teta^[1].valeur:=1;
teta^[1].modal:=False;
teta^[1].test:=0;
k:=2;
for i := 1 to vplist.Items.Count do
begin
for j := 1 to CheckListBox1.Items.Count do
begin
if CheckListBox1.Items.strings[j-1]=vplist.Items.strings[i-1] then
begin
if CheckListBox1.Checked[j-1] then
begin
for l := 1 to modalites^[j] do
begin
teta^[k].place:=j;
teta^[k].utilite:=1;
teta^[k].valeur:=1;
teta^[k].modal:=True;
teta^[k].modal_val:=l;
teta^[k].test:=0;
inc(k);
end;
end
else
begin
teta^[k].place:=j;
teta^[k].utilite:=1;
teta^[k].valeur:=1;
teta^[k].modal:=False;
teta^[k].test:=0;
inc(k);
end;
end;
end;
end;
teta^[k].place:=0;
teta^[k].utilite:=2;
teta^[k].valeur:=1;
teta^[k].modal:=False;
teta^[k].test:=0;
inc(k);
for i := 1 to tclist.Items.Count do
begin
for j := 1 to CheckListBox1.Items.Count do
begin
if CheckListBox1.Items.strings[j-1]=tclist.Items.strings[i-1] then
begin
if CheckListBox1.Checked[j-1] then
begin
for l := 1 to modalites^[j] do
begin
teta^[k].place:=j;
teta^[k].utilite:=2;
teta^[k].valeur:=1;
teta^[k].modal:=True;
teta^[k].modal_val:=l;
teta^[k].test:=0;
inc(k);
end;
end
else
begin
teta^[k].place:=j;
teta^[k].utilite:=2;
teta^[k].valeur:=1;
teta^[k].modal:=False;
teta^[k].test:=0;
inc(k);
end;
end;
end;
end;
for i := 1 to mllist.Items.Count do
begin
for j := 1 to CheckListBox1.Items.Count do
begin
if CheckListBox1.Items.strings[j-1]=mllist.Items.strings[i-1] then
begin
if CheckListBox1.Checked[j-1] then
begin
for l := 1 to modalites^[j] do
begin
teta^[k].place:=j;
teta^[k].utilite:=3;
teta^[k].valeur:=1;
teta^[k].modal:=True;
teta^[k].modal_val:=l;
teta^[k].test:=0;
inc(k);
end;
end
else
begin
teta^[k].place:=j;
teta^[k].utilite:=3;
teta^[k].valeur:=1;
teta^[k].modal:=False;
teta^[k].test:=0;
inc(k);
end;
end;
end;
end;
// formatage & initialisation des autres variables...
reallocmem(gk,nteta*sizeof(cellule));
reallocmem(mk,nteta*sizeof(cellule));
reallocmem(teta_temp,nteta*sizeof(cellule));
copie(teta,gk);
copie(teta,mk);
copie(teta,teta_temp);
// Algo de Fletcher-Reeves
dbgrid1.DataSource:=nil;
gradient(teta);//stocké dans gk
copie(gk,mk);
compteur:=0;
repeat
begin
inc(compteur);
norme_gk:=norme(gk);//on garde la norme de gk;
norme_teta:=norme(teta);
lambda:=maximisation;
fois(lambda,mk);
plus(teta,teta,mk);
gradient(teta);
beta:=sqr(norme(gk))/sqr(norme_gk);
fois(beta,mk);
plus(mk,gk,mk);
end;
until (abs(norme(teta)-norme_teta)<0.001);
lteta:=f(teta);
copie(teta,teta_temp);
for i := 2 to nteta do if (i<>nteta_vp+1) then teta_temp^[i].valeur:=0;
lzero:=f(teta_temp);
dbgrid1.DataSource:=datasource1;
teta_view.Show;
teta_view.affiche(teta);
end;
//------------------------------------------------------------------------------
procedure TForm3.parametrespardfaut1Click(Sender: TObject);
var
rep : string;
begin
rep:=InputBox('Entrez la n° du champ','correspondant au mode choisit','1');
_place_mode:=strtoint(rep);
end;
//------------------------------------------------------------------------------
procedure TForm3.Afficherteta1Click(Sender: TObject);
begin
teta_view.Show;
teta_view.affiche(teta);
end;
//------------------------------------------------------------------------------
end.
2003-06-21