/* ============================= */
void projX (double **tabX, double **projsurX){
int nlX,ncX,i,j;
double **provi1, **provi2, **provi3;
nlX=tabX[0][0];
ncX=tabX[1][0];
taballoc(&provi1,ncX,ncX);
prodmatAtAB (tabX, provi1); /* provi1=XtX */
taballoc(&provi2,ncX,ncX);
dinvG(provi1,provi2); /* provi2=(XtX)-1 */
freetab(provi1);
/*taballoc(&provi1,nlX,ncX);
prodmatABC(tabX,provi2,provi1); provi1=X(XtX)-1
*/
taballoc(&provi3,ncX,nlX);
for (i=1; i<=nlX;i++){
for (j=1; j<=ncX;j++){
provi3[j][i]=tabX[i][j]; /* provi3=Xt */
}
}
prodmatABC(provi2,provi3,projsurX); /* projsurX=(XtX)-1Xt */
freetab(provi2);
freetab(provi3);
}
int is_correct_syntax(const char *str, t_node **list, t_type *type)
{
char **split;
int ret;
if ((ret = is_correct_syntax2(str, type)))
return (ret);
split = ft_strsplit(str, ' ');
if (tablen(split) == 3 && !ft_contain(split[0], '-') &&
!name_exist(*list, split[0]))
{
add_cell(list, split, *type);
freetab(split);
return (NODE);
}
else if (tablen(split) == 1)
ret = is_correct_syntax3(str, split, list);
if (ret == EDGE)
return (ret);
else
{
ft_putstr_fd("Syntax error : ", 2);
ft_putendl_fd(str, 2);
}
freetab(split);
return (FALSE);
}
/*DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,
$ WORK, LWORK, INFO ) */
void dinvG(double **X, double **X_inv)
{
int i,j, k, l,error,size,lwork;
size=X[1][0];
double *A = (double *)calloc((size_t)size*size, sizeof(double));/*doubleArray(size*size);*/
double *D = (double *)calloc((size_t)size, sizeof(double));/*doubleArray(size*1);*/
double *U = (double *)calloc((size_t)size*size, sizeof(double));
double *V = NULL,work1,*work;
double **XU, **XUred;
const char jobu='A',jobvt='N';
taballoc(&XU,size,size);
lwork=-1;
for (i = 0, j = 1; j <= size; j++) {
for (k = 1; k <= size; k++) {
A[i] = X[k][j];
i++;
}
}
F77_CALL(dgesvd)(&jobu, &jobvt,&size, &size,A, &size, D,U,&size,V,&size,&work1, &lwork,&error);
lwork=(int)floor(work1);
if (work1-lwork>0.5) lwork++;
work=(double *)calloc((size_t)lwork,sizeof(double));
/* actual call */
F77_NAME(dgesvd)(&jobu, &jobvt,&size, &size,A, &size, D,U,&size,V,&size,work, &lwork,&error);
free(work);
if (error) {
Rprintf("error in svd: %d\n", error);
}
i = 0;
l=0;
for ( j = 1; j <= size; j++) {
for (k = 1; k <= size; k++) {
XU[k][j] = U[i];
i++;
}
if (D[j-1]>0.00000000001) l=l+1;
}
taballoc(&XUred,size,l);
for (i=1;i<=size;i++) {
for (k=1;k<=l;k++) {
XUred[i][k]=pow(D[k-1],-0.5)*XU[i][k];
}
}
prodmatAAtB (XUred, X_inv);
freetab(XUred);
free(A);
free(D);
free(U);
freetab(XU);
}
int is_correct_syntax3(const char *str, char **split, t_node **list)
{
freetab(split);
split = ft_strsplit(str, '-');
if (tablen(split) == 2)
{
if (add_edge(*list, split[0], split[1]))
{
freetab(split);
return (EDGE);
}
}
return (0);
}
void hub_serv(char *str, t_serv clt)
{
char **tabcmd;
if (strlen(str) < 2)
return ;
if (str[ft_strlen(str) - 1] == '\n')
str[ft_strlen(str) - 1] = '\0';
tabcmd = ft_strsplit(str, ' ');
if (ft_strcmp(tabcmd[0], "quit") == 0)
check_quit(tabcmd, clt);
else if (ft_strcmp(tabcmd[0], "cd") == 0)
serv_cd(tabcmd, clt);
else if (ft_strcmp(tabcmd[0], "ls") == 0)
serv_ls(tabcmd, clt);
else if (ft_strcmp(tabcmd[0], "pwd") == 0)
pwd_serv(tabcmd, clt);
else if (ft_strcmp(tabcmd[0], "put") == 0)
put_serv(tabcmd[1], clt);
else if (ft_strcmp(tabcmd[0], "get") == 0)
get_serv(tabcmd[1], clt);
else
write(clt.cs, "Command unknown to serveur.\n", 28);
freetab(tabcmd);
}
void dad(t_sh *sh, pid_t pid)
{
int status;
char buff[5];
my_memset(buff, 0, 5);
if (sh->actual->piper_read != NULL && sh->actual->fd[0] != 0)
{
close(sh->actual->piper_read->pipe[0]);
close(sh->actual->piper_read->pipe[1]);
}
if (sh->actual->piper_write != NULL)
waitpid(pid, &status, WNOHANG);
else
waitpid(pid, &status, 0);
if (sh->actual->fd[0] != 0)
close(sh->actual->fd[0]);
if (sh->actual->fd[1] != 1)
close(sh->actual->fd[1]);
if (WEXITSTATUS(status) == 0)
return_exec_success(sh);
sprintf(buff, "%d", WEXITSTATUS(status));
my_setenv(&sh->env, "?", buff);
handle_message(status);
freetab(sh->av);
}
static void delete_actions(t_list *actions)
{
t_actions *action;
while (!list_is_empty(actions))
{
action = (t_actions *)list_get_front(actions);
freetab(action->av);
free(action);
list_pop_front(&actions);
}
}
double traceXtdLXq (double **X, double **L, double *d, double *q)
/* Produit matriciel XtDLXQ avec LX comme lag.matrix */
{
/* Declarations de variables C locales */
int j, i, lig, col;
double **auxi, **A, trace;
/* Allocation memoire pour les variables C locales */
lig = X[0][0];
col = X[1][0];
taballoc(&auxi, lig, col);
taballoc(&A, col, col);
/* Calcul de LX */
prodmatABC(L, X, auxi);
/* Calcul de DLX */
for (i=1;i<=lig;i++) {
for (j=1;j<=col;j++) {
auxi[i][j] = auxi[i][j] * d[i];
}
}
/* Calcul de XtDLX */
prodmatAtBC(X,auxi,A);
/* Calcul de trace(XtDLXQ) */
trace=0;
for (i=1;i<=col;i++) {
trace = trace + A[i][i] * q[i];
}
/* Libération des réservations locales */
freetab (auxi);
freetab (A);
return(trace);
}
void del_env_game(t_env *env)
{
int i;
i = 0;
while (i < (env->len * env->len))
{
delwin(env->win[i]);
i++;
}
free (env->login);
free (env->win);
freetab((void**)env->tab, env->len);
free(env->tab);
}
double testFreducedmodel(double **predX, double **projectX, double **projectXZ, double **tabres, double **tabXZ, double Fobs, int q, int n, int p, int nperm){
int i,j,k,nrowY,ncolY,NGT=0, ncolX, ncolXZ;
double **Yperm,R2X=0,R2XZ, Fi,**tabpredX,**tabpredXZ, **proviX, **proviXZ, **tabX;
nrowY=predX[0][0];
ncolY=predX[1][0];
ncolXZ=tabXZ[1][0];
ncolX=ncolXZ-1;
taballoc(&Yperm,nrowY,ncolY);
taballoc(&tabpredXZ,nrowY,ncolY);
taballoc(&proviXZ,ncolXZ,ncolY);
if(ncolX>0){
taballoc(&tabpredX,nrowY,ncolY);
taballoc(&proviX,ncolX,ncolY);
taballoc(&tabX,nrowY, ncolX);
for (i=1;i<=nrowY;i++){
for (j=1;j<=ncolX;j++){
tabX[i][j]=tabXZ[i][j];
}
}
}
for (i=1;i<=nperm;i++){
aleapermutmat (tabres);
for (k=1;k<=nrowY;k++){
for (j=1;j<=ncolY;j++){
Yperm[k][j]=predX[k][j]+tabres[k][j];
}
}
prodmatABC(projectXZ,Yperm,proviXZ);
prodmatABC(tabXZ,proviXZ,tabpredXZ);
if(ncolX>0){
prodmatABC(projectX,Yperm,proviX);
prodmatABC(tabX,proviX,tabpredX);
}
if(ncolX>0){
R2X=calcR2(Yperm,tabpredX);
}
R2XZ=calcR2(Yperm,tabpredXZ);
Fi=calcF(R2X,R2XZ,q,n,p);
if (Fi>=Fobs) NGT=NGT+1;
}
freetab(Yperm);
freetab(tabpredXZ);
freetab(proviXZ);
if(ncolX>0){
freetab(tabpredX);
freetab(tabX);
freetab(proviX);
}
return(((double)NGT+1)/((double)nperm+1));
}
void ft_env(t_s *s, int nbenv)
{
if (nbenv > 0)
{
ft_enva(s, nbenv);
ft_exec(s, (nbenv + 1), s->tempenv);
freetab(s->tempenv);
s->tempenv = NULL;
}
else
{
s->tempenv = NULL;
ft_exec(s, 1, s->myenv);
}
}
/* (Private.) Called by #parse to get the next token (as required by
* racc). Returns a 2-element array: [TOKEN_SYM, VALUE].
*/
VALUE cast_Parser_next_token(VALUE self) {
cast_Parser *self_p;
VALUE token, pos;
Get_Struct(self, Parser, self_p);
/* clear the token val */
rb_ary_store(self_p->token, 1, Qnil);
/* call the lexer */
yylex(self, self_p);
/* return nil if EOF */
if (rb_ary_entry(self_p->token, 0) == Qnil)
{
freetab(self_p->file);
return Qnil;
}
/**/
unsigned int diff;
diff = strlen(self_p->bot) - strlen(self_p->tok);
int line = 0;
int col = 0;
int count = 0;
while (self_p->file[line] && count + strlen(self_p->file[line]) < diff)
{
count += strlen(self_p->file[line]) + 1;
line += 1;
}
col = diff - count;
//////////////////////////////////////////////////////
/* set self.pos */
pos = rb_iv_get(self, "@pos");
rb_funcall(pos, rb_intern("col_num="), 1, LONG2NUM(col));
rb_funcall(pos, rb_intern("line_num="), 1, LONG2NUM(line + 1));
/* make token */
token = rb_funcall(rb_const_get(cast_cParser, rb_intern("Token")),
rb_intern("new"), 2,
rb_funcall2(pos, rb_intern("dup"), 0, NULL),
rb_ary_entry(self_p->token, 1));
/* put the token in the array */
rb_ary_store(self_p->token, 1, token);
return self_p->token;
}
int launch_action(t_actions *action, t_player *player,
t_kernel *kernel)
{
int i;
i = 0;
while (action->av[0] && g_functions[i].name &&
strcmp(action->av[0], g_functions[i].name))
++i;
if (action->av[0] && g_functions[i].name)
if (g_functions[i].function(action->av, player->client, kernel))
return (-1);
freetab(action->av);
list_pop(&(player->actions), action);
return (0);
}
void hub_client(char *str, t_client clt)
{
char **tabcmd;
str = tabtosp(str);
tabcmd = ft_strsplit(str, ' ');
if (ft_strcmp(tabcmd[0], "quit") == 0)
quit_hub(str, clt);
else if (ft_strcmp(tabcmd[0], "cd") == 0)
cd_hub(str, clt);
else if (ft_strcmp(tabcmd[0], "ls") == 0)
ls_hub(str, clt);
else if (ft_strcmp(tabcmd[0], "pwd") == 0)
pwd_hub(str, clt);
else
hub_client2(tabcmd, clt);
freetab(tabcmd);
}
static int call_cmd(int i, t_client *client, char **av, t_kernel *kernel)
{
int ret;
if (g_functions[i].type == CLIENT && client->player)
{
if (FALSE == add_action(g_functions[i].timeout, client->player, av, 0))
ret = -1;
}
else if ((g_functions[i].type == GRAPHIC && client->graphic) ||
(g_functions[i].type == AUTH && !(client->graphic) &&
!(client->player)))
{
ret = g_functions[i].function(av, client, kernel);
freetab(av);
}
if (ret)
return (ret);
return (0);
}
int resolve(char **tab, char **tryresult, int *pattern, int x)
{
if (pattern[0] == pattern[1])
{
putabl(tryresult);
return (1);
}
if (resolve_son(tab, tryresult, pattern, x))
return (1);
if (pattern[1] != 0)
del_pattern(tryresult, pattern[1] - 1);
else if (pattern[1] == 0)
{
freetab(tryresult);
tryresult = holy_result(x + 1);
pattern[1] = 0;
if (resolve(tab, tryresult, pattern, x + 1))
return (1);
else
return (0);
}
return (0);
}
void delete_command(t_command *command, t_command **list)
{
t_command *tmp;
t_command *tfree;
if (command && command->command)
free(command->command);
if (command && command->split_command)
freetab(command->split_command);
if ((*list) && command && (*list) == command)
(*list) = (*list)->next;
else
{
tmp = (*list);
while (tmp && tmp->next != command)
tmp = tmp->next;
if (tmp && tmp->next)
{
tfree = tmp->next;
tmp->next = tmp->next->next;
free(tfree);
}
}
}
void ft_envi(t_s *s, int nbenv)
{
int i;
i = 0;
if (nbenv > 0)
{
s->tempenv = (char **)malloc(sizeof(char *) * (nbenv + 1));
while (i < nbenv)
{
s->tempenv[i] = ft_strdup(s->in[i + 2]);
i++;
}
s->tempenv[i] = NULL;
ft_exec(s, (nbenv + 2), s->tempenv);
freetab(s->tempenv);
s->tempenv = NULL;
}
else
{
s->tempenv = NULL;
ft_exec(s, 2, s->tempenv);
}
}
void alreadyintb3(t_data *data, char **tabb)
{
freetab(data->builttab);
data->builttab = newtab(tabb);
freetab(tabb);
}
void repClass(int *ioptsm1,
int *ngr1,
int *nbech1,
int *nlig1,
int *nclatot1,
int *maxnlim1,
int *pb,
int *ncla,
int *tablim1,
double *hp,
int *nech,
double *tabh1)
{
int i, j, k, ilig, numpic, nclasspic, numclasspic, iech;
int ioptsm, ngr, nbech, nlig, nclatot, maxnlim;
double xinf, xsup, maxpic, x;
double **tablim;
double **tabh;
/*
/ recover arguments
*/
ioptsm = *ioptsm1;
ngr = *ngr1;
nbech = *nbech1;
nlig = *nlig1;
nclatot = *nclatot1;
maxnlim = *maxnlim1;
/*
/ declare and allocate memory for two dimensional tables
*/
taballoc(&tablim, maxnlim+1, ngr);
taballoc(&tabh, nbech, nclatot);
/*
/ recover the table of class limits
*/
k=0;
for (i=1; i<=maxnlim+1; i++) {
for (j=1; j<=ngr; j++) {
tablim[i][j] = (double) tablim1[k];
k=k+1;
}
}
if (ioptsm == 1) {
/*
/ compute the sum of peaks within each class
*/
numpic = 0;
for (ilig=1; ilig<=nlig; ilig++) {
nclasspic = 0;
numpic = numpic + 1;
x = (double) pb[numpic-1];
for (i=1; i<=ngr; i++) {
for (j=2; j<=ncla[i-1]+1; j++) {
xinf = (double) tablim[j-1][i];
xsup = (double) tablim[j][i];
if ((xinf <= x ) && (x < xsup)) {
numclasspic = nclasspic + j - 1;
tabh[(int) nech[ilig-1] ][numclasspic] = tabh[(int) nech[ilig-1] ][numclasspic] + hp[ilig-1];
goto suite;
}
}
nclasspic = nclasspic + ncla[i-1];
}
suite:;
}
} else {
/*
/ compute the max of peaks within each class
*/
for (iech=1; iech<=nbech; iech++) {
numpic = 0;
maxpic = 0;
for (ilig=1; ilig<=nlig; ilig++) {
numpic = numpic + 1;
if (nech[ilig-1] == iech) {
x = (double) pb[numpic-1];
nclasspic = 0;
for (i=1; i<=ngr; i++) {
for (j=2; j<=ncla[i-1]+1; j++) {
numclasspic = nclasspic + j - 1;
xinf = (double) tablim[j-1][i];
xsup = (double) tablim[j][i];
if ((xinf <= x ) && (x < xsup)) {
if (tabh[iech][numclasspic] < hp[ilig-1]) {
tabh[iech][numclasspic] = hp[ilig-1];
}
}
}
nclasspic = nclasspic + ncla[i-1];
}
}
}
}
}
/*
/ set up output table
*/
k=0;
for (i=1; i<=nbech; i++) {
for (j=1; j<=nclatot; j++) {
tabh1[k] = tabh[i][j];
k=k+1;
}
}
/*
/ free declared memory
*/
freetab (tablim);
freetab (tabh);
}
void gearymoran (int *param, double *data, double *bilis,
double *obs, double *result, double *obstot, double *restot)
{
/* Declarations des variables C locales */
int nobs, nvar, nrepet, i, j, k, krepet, kvar ;
int *numero;
double provi;
double *poili;
double **mat, **tab, **tabperm;
/* Allocation memoire pour les variables C locales */
nobs = param[0];
nvar = param [1];
nrepet = param [2];
vecalloc(&poili,nobs);
taballoc(&mat,nobs,nobs);
taballoc(&tab,nobs,nvar);
taballoc(&tabperm,nobs,nvar);
vecintalloc (&numero, nobs);
/* Définitions des variables C locales */
k = 0;
for (i=1; i<=nvar; i++) {
for (j=1; j<=nobs; j++) {
tab[j][i] = data[k] ;
k = k+1 ;
}
}
k = 0;
provi = 0;
for (j=1; j<=nobs; j++) {
for (i=1; i<=nobs; i++) {
mat[i][j] = bilis[k] ;
provi = provi + bilis[k];
k = k+1 ;
}
}
for (j=1; j<=nobs; j++) {
for (i=1; i<=nobs; i++) {
mat[i][j] = mat[i][j]/provi ;
}
}
/* mat contient une distribution de fréquence bivariée */
for (j=1; j<=nobs; j++) {
provi = 0;
for (i=1; i<=nobs; i++) {
provi = provi + mat[i][j] ;
}
poili[j] = provi;
}
/* poili contient la distribution marginale
le test sera du type xtPx avec x centré normé pour la pondération
marginale et A = QtFQ soit la matrice des pij-pi.p.j */
matmodifcn(tab,poili);
/* le tableau est normalisé pour la pondération marginale de la forme*/
for (j=1; j<=nobs; j++) {
for (i=1; i<=nobs; i++) {
mat[i][j] = mat[i][j] -poili[i]*poili[j] ;
}
}
for (kvar=1; kvar<=nvar; kvar++) {
provi = 0;
for (j=1; j<=nobs; j++) {
for (i=1; i<=nobs; i++) {
provi = provi + tab[i][kvar]*tab[j][kvar]*mat[i][j] ;
}
}
obs[kvar-1] = provi;
}
k=0;
/* les résultats se suivent par simulation */
for (krepet=1; krepet<=nrepet; krepet++) {
getpermutation (numero, krepet);
matpermut (tab, numero, tabperm);
matmodifcn (tabperm,poili);
for (kvar=1; kvar<=nvar; kvar++) {
provi = 0;
for (j=1; j<=nobs; j++) {
for (i=1; i<=nobs; i++) {
provi = provi + tabperm[i][kvar]*tabperm[j][kvar]*mat[i][j] ;
}
}
result[k] = provi;
k = k+1;
}
}
/* libération mémoire locale */
freevec(poili);
freetab(mat);
freeintvec(numero);
freetab(tab);
freetab(tabperm);
}
void VarianceDecompInOrthoBasis (int *param, double *z, double *matvp,
double *phylogram, double *phylo95,double *sig025, double *sig975,
double *R2Max, double *SkR2k, double*Dmax, double *SCE, double *ratio)
{
/* param contient 4 entiers : nobs le nombre de points, npro le nombre de vecteurs
nrepet le nombre de permutations, posinega la nombre de vecteurs de la classe posi
qui est nul si cette notion n'existe pas. Exemple : la base Bscores d'une phylogénie a posinega = 0
mais la base Ascores a posinega à prendre dans Adim
z est un vecteur à nobs composantes de norme 1
pour la pondération uniforme. matvp est une matrice nobsxnpro contenant en
colonnes des vecteurs orthonormés pour la pondération uniforme. En géné
La procédure placera
dans phylogram les R2 de la décomposition de z dans la base matvp
dans phylo95 les quantiles 0.95 des R2
dans sig025 les quantiles 0.025 des R2 cumulés
dans sig975 les quantiles 0.975 des R2 cumulés
Ecrit à l'origine pour les phylogénies
peut servir pour une base de vecteurs propres de voisinage */
/* Declarations des variables C locales */
int nobs, npro, nrepet, i, j, k, n1, n2, n3, n4;
int irepet, posinega, *numero, *vecrepet;
double **vecpro, *zperm, *znorm;
double *locphylogram, *modelnul;
double a1, provi, **simul, *copivec, *copicol;
/* Allocation memoire pour les variables C locales */
nobs = param[0];
npro = param [1];
nrepet = param [2];
posinega = param[3];
vecalloc (&znorm, nobs);
vecalloc (&zperm, nobs);
vecalloc (&copivec, npro);
vecalloc (&copicol, nrepet);
taballoc (&vecpro, nobs, npro);
taballoc (&simul, nrepet, npro);
vecalloc (&locphylogram, npro);
vecalloc (&modelnul, npro);
vecintalloc (&numero, nobs);
vecintalloc (&vecrepet, nrepet);
/* Définitions des variables C locales */
for (i = 1 ; i<= nobs; i++) znorm[i] = z[i-1];
for (i = 1 ; i<= npro; i++) modelnul[i] = (double) i/ (double) npro;
k = 0;
for (j=1; j<=npro; j++) {
for (i=1; i<=nobs; i++) {
vecpro[i][j] = matvp[k] ;
k = k+1 ;
}
}
/* calcul du phylogramme observé */
for (j = 1; j<= npro; j++) {
provi = 0;
for (i=1; i<=nobs; i++) provi = provi + vecpro[i][j]*znorm[i];
provi = provi*provi/nobs/nobs;
locphylogram[j] = provi;
}
for (i =1 ; i<= npro ; i++) phylogram[i-1] = locphylogram[i];
/* calcul des simulations
Chaque ligne de simul est un phylogramme après permutation des données */
for (irepet=1; irepet<=nrepet; irepet++) {
getpermutation (numero, irepet);
vecpermut (znorm, numero, zperm);
provi = 0;
for (j = 1; j<= npro; j++) {
provi = 0;
for (i=1; i<=nobs; i++) provi = provi + vecpro[i][j]*zperm[i];
provi = provi*provi/nobs/nobs;
simul[irepet][j] = provi;
}
}
/* calcul du test sur le max du phylogramme */
for (irepet=1; irepet<=nrepet; irepet++) {
for (j=1; j<=npro; j++) copivec[j] = simul[irepet][j];
R2Max[irepet] = maxvec(copivec);
provi=0;
for (j=1; j<=npro; j++) provi = provi + j*simul[irepet][j];
SkR2k[irepet] =provi;
if (posinega>0) {
provi=0;
for (j=1; j<posinega; j++) provi = provi + simul[irepet][j];
ratio[irepet] = provi;
}
}
R2Max[0] = maxvec(locphylogram);
provi=0;
for (j=1; j<=npro; j++) provi = provi + j*locphylogram[j];
SkR2k[0] =provi;
if (posinega>0) {
provi=0;
for (j=1; j<posinega; j++) provi = provi + locphylogram[j];
ratio[0] = provi;
}
/* quantiles 95 du sup */
n1 = (int) floor (nrepet*0.95);
n2 = (int) ceil (nrepet*0.95);
for (i =1; i<=npro; i++) {
for (irepet = 1; irepet<= nrepet; irepet++) {
copicol[irepet] = simul [irepet][i];
}
trirap (copicol, vecrepet);
phylo95[i-1] = 0.5*(copicol[n1]+copicol[n2]);
}
for (irepet=1; irepet<=nrepet; irepet++) {
provi = 0;
for (j=1; j<=npro; j++) {
provi = provi + simul[irepet][j];
copivec[j] = provi;
}
for (j=1; j<=npro; j++) simul[irepet][j] = copivec[j];
}
n1 = (int) floor (nrepet*0.025);
n2 = (int) ceil (nrepet*0.025);
n3 = (int) floor (nrepet*0.975);
n4 = (int) ceil (nrepet*0.975);
/* quantiles 2.5 du cumul */
for (i =1; i<=npro; i++) {
for (irepet = 1; irepet<= nrepet; irepet++) {
copicol[irepet] = simul [irepet][i];
}
trirap (copicol, vecrepet);
sig025[i-1] = 0.5*(copicol[n1]+copicol[n2]);
sig975[i-1] = 0.5*(copicol[n3]+copicol[n4]);
}
provi = 0;
for (j=1; j<=npro; j++) {
a1 = modelnul[j];
provi = provi + locphylogram[j];
locphylogram[j] = provi-a1;
for (irepet = 1; irepet<= nrepet; irepet++) {
simul [irepet][j] = simul [irepet][j]-a1;
}
}
/* simul contient maintenant les cumulés simulés en écarts */
/* locphylogram contient maintenant les cumulés observés en écart*/
/* Dmax */
for (j=1; j<=npro; j++) {
for (irepet=1; irepet<=nrepet; irepet++) {
for (j=1; j<=npro; j++) copivec[j] = simul[irepet][j];
Dmax[irepet] = maxvec(copivec);
provi=0;
for (j=1; j<=npro; j++) provi = provi + copivec[j]* copivec[j];
SCE[irepet] =provi;
}
}
Dmax[0] = maxvec (locphylogram);
provi=0;
for (j=1; j<=npro; j++) provi = provi +locphylogram[j]*locphylogram[j];
SCE[0] =provi;
/* retour */
freevec (znorm);
freevec (modelnul);
freevec(copivec);
freevec(copicol);
freevec (zperm);
freetab (vecpro);
freetab (simul);
freevec (locphylogram);
freeintvec (numero);
freeintvec (vecrepet);
}
void testglobal(double *eigenvec, double *eigenval, int *nlig, int *ncol, double *xR, int *nsim, double *sim){
int k,nl,nc,i,j;
double **Evec,*x,*xperm,*cor,*Eval;
/* 1 I : somme (lambda)*R2 */
/* 2 I+ : somme (lambda posi)*R2 */
/* 3 I- : somme (lambda nega)*R2 */
nl=*nlig;
nc=*ncol;
taballoc(&Evec,nl,nc);
vecalloc(&Eval,nc);
vecalloc(&cor,nc);
vecalloc(&x,nl);
vecalloc(&xperm,nl);
k = 0;
for (i=1; i<=nl; i++) {
for (j=1; j<=nc; j++) {
Evec[i][j] = eigenvec[k];
k = k + 1;
}
}
for (i=1; i<=nl; i++) {
x[i]=xR[i-1];
xperm[i]=x[i];
}
for (i=1; i<=nc; i++) {
Eval[i]=eigenval[i-1];
}
prodatBc(x, Evec,cor);
for(i=1;i<=nc;i++){
sim[0]=sim[0]+Eval[i]*cor[i]*cor[i];
if(Eval[i]>0.0){
sim[1]=sim[1]+Eval[i]*cor[i]*cor[i];
}
if(Eval[i]<0.0){
sim[2]=sim[2]+Eval[i]*cor[i]*cor[i];
}
}
for (i=1;i<=*nsim;i++){
aleapermutvec (xperm);
prodatBc(xperm, Evec,cor);
for(k=1;k<=nc;k++){
sim[3*i]=sim[3*i]+Eval[k]*cor[k]*cor[k];
if(Eval[k]>0.0){
sim[3*i+1]=sim[3*i+1]+Eval[k]*cor[k]*cor[k];
}
if(Eval[k]<0.0){
sim[3*i+2]=sim[3*i+2]+Eval[k]*cor[k]*cor[k];
}
}
}
freevec(Eval);
freetab(Evec);
freevec(cor);
freevec(x);
freevec(xperm);
}
void forwardsel (double *tabXR, double *tabYR, int *nrowXR, int *ncolXR, int *ncolYR, double *pvalue, int *ordre,
double *Fvalue, int *nperm, double *R2cum, double *adjR2cum, int *K, double *R2seuil, double *adjR2seuil, double *R2more, int *nbcovar, double *alpha, int *verbose){
/* CANOCO 4.5 p. 49 */
/* nouvelle version 01/11/2004 */
/* on ne stocke plus le projecteur au complet (qui est n x n)
ce qui permet d'economiser de la RAM quand n est grand
modifie aussi testFreducedmodel */
int i,j,k,l,nrowX,ncolX, ncolY, *vecrest, *vecsel, R2maxj=0;
double **tabX, **tabY, **tabres, **tabpred1, **tabpred2, **tabXnew, R2max=0, adjR2max=0,R2j, R2X, R2XZ, Fobs,**projectX,**projectXZ, **provi;
nrowX=*nrowXR;
ncolX=*ncolXR;
ncolY=*ncolYR;
taballoc (&tabX, nrowX, ncolX);
taballoc (&tabY, nrowX, ncolY);
taballoc (&tabres, nrowX, ncolY);
taballoc (&tabpred1, nrowX, ncolY);
taballoc (&tabpred2, nrowX, ncolY);
vecintalloc(&vecrest,ncolX);
vecintalloc(&vecsel,ncolX);
taballoc (&projectX, 1,nrowX);
/* Passage des objets R en C */
k = 0;
for (i=1; i<=nrowX; i++) {
for (j=1; j<=ncolX; j++) {
tabX[i][j] = tabXR[k];
k = k + 1;
}
}
k = 0;
for (i=1; i<=nrowX; i++) {
for (j=1; j<=ncolY; j++) {
tabY[i][j] = tabYR[k];
k = k + 1;
tabpred1[i][j]=0;
}
}
for (i=1; i<=ncolX; i++) vecrest[i]=i;
R2X=0;
for (i=1; i<=ncolX; i++){
if ((R2max>*R2seuil) || (i>*K) || (i>(nrowX-1)) || (adjR2max>*adjR2seuil)) {
if ((i>*K) )
Rprintf("Procedure stopped (K criteria)\n");
if ((i>(nrowX-1)))
Rprintf("Procedure stopped: number of variables included equals number of rows minus one. All is explained ! Redo your analysis with other parameters.\n");
break;
}
if(*verbose == 1){
Rprintf("Testing variable %d\n",i);
}
R2max=0;
adjR2max=0;
R2maxj=0;
taballoc(&tabXnew, nrowX, i);
taballoc(&projectXZ, i, nrowX);
taballoc(&provi,i,ncolY);
for (j=1; j<=ncolX; j++){
if (vecrest[j]>0){ /* Selection de la variable j base sur le R2 */
vecsel[i]=j;
constnewX(tabX,tabXnew,vecsel);
projX(tabXnew,projectXZ);
prodmatABC(projectXZ,tabY,provi);
prodmatABC(tabXnew,provi,tabpred2);
R2j=calcR2(tabY,tabpred2);
if (R2j>R2max) {
R2max=R2j;
adjR2max=calcR2adj(R2max,nrowX,i);
R2maxj=j;
}
}
} /* for (j=1; j<=ncolX; j++) */
/* test de la variable j selectionne */
if ((i>1) && (fabs(R2max-R2cum[i-2])<*R2more)){
Rprintf("Procedure stopped (R2more criteria): variable %d explains only %f of the variance.\n",i,(fabs(R2max-R2cum[i-2])));
freetab(tabXnew);
break;
}
if ((R2max>*R2seuil)){
Rprintf("Procedure stopped (R2thresh criteria) R2cum = %f with %d variables (> %f)\n", R2max, i, *R2seuil);
break;
}
if ((adjR2max>*adjR2seuil)){
Rprintf("Procedure stopped (adjR2thresh criteria) adjR2cum = %f with %d variables (> %f)\n", adjR2max, i, *adjR2seuil);
break;
}
vecsel[i]=R2maxj;
R2cum[i-1]=R2max;
adjR2cum[i-1]=adjR2max;
ordre[i-1]=vecsel[i];
vecrest[R2maxj]=0;
constnewX(tabX,tabXnew,vecsel);
projX(tabXnew,projectXZ);
prodmatABC(projectXZ,tabY,provi);
prodmatABC(tabXnew,provi,tabpred2);
for (k=1;k<=nrowX;k++){
for (l=1;l<=ncolY;l++){
tabres[k][l]=tabY[k][l]-tabpred1[k][l];
}
}
R2XZ=R2max;
Fobs=calcF(R2X,R2XZ,1,nrowX,i+(*nbcovar));
Fvalue[i-1]=Fobs;
pvalue[i-1]=testFreducedmodel(tabpred1,projectX,projectXZ,tabres, tabXnew, Fobs,1,nrowX,i+(*nbcovar),*nperm);
for (k=1;k<=nrowX;k++){
for (l=1;l<=ncolY;l++){
tabpred1[k][l]=tabpred2[k][l];/* mettre dans pred1 les predictions du nouvo model */
}
}
freetab(projectX);
taballoc(&projectX, i, nrowX);
for (k=1;k<=i;k++){
for (l=1;l<=nrowX;l++){
projectX[k][l]=projectXZ[k][l];
}
}
R2X=R2XZ;
freetab(tabXnew);
freetab(projectXZ);
freetab(provi);
if ((pvalue[i-1]>*alpha)) {
Rprintf("Procedure stopped (alpha criteria): pvalue for variable %d is %f (> %f)\n",i,pvalue[i-1],*alpha);
ordre[i-1]=0;
break;
}
}/* for (i=1; i<=ncolX; i++) */
freetab(projectX);
freeintvec(vecsel);
freeintvec(vecrest);
freetab(tabX);
freetab(tabY);
freetab(tabres);
freetab(tabpred1);
freetab(tabpred2);
}
