Permutations dans un table de contingence

Postez ici vos questions, réponses, commentaires ou suggestions - Les sujets seront ultérieurement répartis dans les archives par les modérateurs

Modérateur : Groupe des modérateurs

Hubert RAYMONDAUD
Messages : 23
Enregistré le : 02 Déc 2012, 13:55

Permutations dans un table de contingence

Messagepar Hubert RAYMONDAUD » 17 Oct 2017, 20:17

Bonjour
Je prépare des exemples pour une fiche sur les tests fishériens (=de permutation) sur une table de contingence r x c.
Je cherche s'il existe une fonction R qui permette de générer toutes les tables de contingence possibles étant donné des sommes marginales fixées.
(dans le même esprit que celui de la fonction combn(...) qui génère toutes les combinaisons possibles de k valeurs prises dans une liste de n).
Cordialement
H.R.

Logez Maxime
Messages : 3138
Enregistré le : 26 Sep 2006, 11:35

Re: Permutations dans un table de contingence

Messagepar Logez Maxime » 31 Oct 2017, 13:07

Bonjour,

je ne connais pas ce genre de fonctions par contre tu en as une qui génère des tables (pas toutes à voir peut-être comment l'adapter), r2dtable de la librairie stats.

Cordialement,
Maxime

Pierre-Yves Berrard
Messages : 1029
Enregistré le : 12 Jan 2016, 23:30

Re: Permutations dans un table de contingence

Messagepar Pierre-Yves Berrard » 31 Oct 2017, 13:28

Hubert RAYMONDAUD a écrit :générer toutes les tables de contingence possibles étant donné des sommes marginales fixées

Intuitivement, le nombre de possibilités doit augmenter très rapidement avec le nombre de modalités et la valeur des marges.
Par curiosité, quelles sont les ordres de grandeurs, dans le cas présent ?
PY

François Bonnot
Messages : 537
Enregistré le : 10 Nov 2004, 15:19
Contact :

Re: Permutations dans un table de contingence

Messagepar François Bonnot » 02 Nov 2017, 16:23

Bonjour,
Le code suivant donne la solution :

Code : Tout sélectionner

comb <- function(n,k) if (k==1) n else do.call(rbind,lapply(0:n,function(i) cbind(i,comb(n-i,k-1))))

rbind2 <- function(m,p) apply(p,1,function(z) rbind(data.frame(m),z))

permut1 <- function(m,sr,nr,sc,nc) {
    if (!is.null(m)) {
        sc <- sc-colSums(m)
        nr <- nr-nrow(m)
        k <- nrow(m)+1
    }
    else k <- 1
    if (nr==1) z <- sc
    else {
        z <- comb(sr[k],nc)
        z <- z[apply(z,1,function(u) all(u<=sc)),]
    }
    rbind2(m,matrix(z,ncol=nc))
}

permut2 <- function(li,sr,nr,sc,nc) {
    li2 <- do.call(c,lapply(li,permut1,sr,nr,sc,nc))
    return (if (nrow(li2[[1]])==nr) li2 else permut2(li2,sr,nr,sc,nc))
}

permut.table <- function(m) {
    p <- permut2(list(NULL),rowSums(m),nrow(m),colSums(m),ncol(m))
    lapply(p, function(x) { rownames(x) <- colnames(x) <- NULL ; as.matrix(x) })
}

Exemple :

Code : Tout sélectionner

(m <- matrix(c(1,0,2,1,1,0,0,0,1,1,0,0),ncol=4))
permut.table(m)

quels sont les ordres de grandeurs, dans le cas présent

Par exemple pour une matrice carrée d'ordre n avec toutes les marges égales à 1, le nombre de combinaisons est n!

Code : Tout sélectionner

permut.table(diag(3))
François

Hubert RAYMONDAUD
Messages : 23
Enregistré le : 02 Déc 2012, 13:55

Re: Permutations dans un table de contingence

Messagepar Hubert RAYMONDAUD » 17 Nov 2017, 21:43

Bonsoir
Merci François
Et chapeau bas car pas du tout évidente la solution.
Un bel exercice d'algorithmique.
Cordialement

François Bonnot
Messages : 537
Enregistré le : 10 Nov 2004, 15:19
Contact :

Re: Permutations dans un table de contingence

Messagepar François Bonnot » 28 Nov 2017, 07:40

Bonjour Hubert,
Merci pour le retour.
Cependant cet algorithme n'est pas optimal parce qu'il examine de trop nombreuses solutions (pas toutes heureusement) qu'il élimine ensuite (dans la ligne z <- z[apply(z,1,function(u) all(u<=sc)),]).
Par exemple cette matrice est clairement l'unique permutation de sa classe:

Code : Tout sélectionner

(m <- matrix(c(5,5,5,5,5,5,0,0,0,0,0,0),byrow=TRUE,nrow=2))
     [,1] [,2] [,3] [,4] [,5] [,6]
[1,]    5    5    5    5    5    5
[2,]    0    0    0    0    0    0

Mais l'algorithme prend plusieurs secondes pour la trouver, parce qu'il réalise toutes les permutations de la première ligne (au nombre de (30+6-1)!/30!/(6-1)!=324632) pour n'en conserver qu'une:

Code : Tout sélectionner

permut.table(m)

C'est beaucoup plus rapide d'appliquer la fonction à la transposée de m:

Code : Tout sélectionner

permut.table(t(m))

parce que le nombre de permutations testées n'est que de 6*5=30.
Il existe certainement une façon de trouver directement les permutations.
Affaire à suivre...
François

François Bonnot
Messages : 537
Enregistré le : 10 Nov 2004, 15:19
Contact :

Re: Permutations dans un table de contingence

Messagepar François Bonnot » 01 Déc 2017, 07:36

Bonjour,
Voici un code qui donne directement la liste des permutations sans étape d'élimination de solutions.
Il est plus rapide que le précédent, beaucoup plus dans certains cas (par exemple dans de cas de la matrice m ci-dessus la réponse est immédiate au lieu de prendre quelques secondes), cependant dans le cas général le gain de temps n'est pas aussi important qu'on aurait pu l'espérer.
Seules les fonctions comb() et permut1() ont changé mais je redonne le code complet.
Pour information, la fonction comb(n,k,contr) donne toutes les distributions de n boules dans k cases avec le vecteur des contraintes contr correspondant au nombre maximum de boules dans chaque case.

Code : Tout sélectionner

comb <- function(n,k,contr) if (k==1) n else do.call(rbind,lapply(max(0,n-sum(contr[-1])):min(n,contr[1]),function(i) cbind(i,comb(n-i,k-1,contr[-1]))))

rbind2 <- function(m,p) apply(p,1,function(z) rbind(data.frame(m),z))

permut1 <- function(m,sr,nr,sc,nc) {
    if (is.null(m)) k <- 1
    else {
        sc <- sc-colSums(m)
        nr <- nr-nrow(m)
        k <- nrow(m)+1
    }
    z <- if (nr==1) sc else comb(sr[k],nc,sc)
    rbind2(m,matrix(z,ncol=nc))
}

permut2 <- function(li,sr,nr,sc,nc) {
    li2 <- do.call(c,lapply(li,permut1,sr,nr,sc,nc))
    return (if (nrow(li2[[1]])==nr) li2 else permut2(li2,sr,nr,sc,nc))
}

permut.table <- function(m) {
    p <- permut2(list(NULL),rowSums(m),nrow(m),colSums(m),ncol(m))
    lapply(p, function(x) { rownames(x) <- colnames(x) <- NULL ; as.matrix(x) })
}
François


Retourner vers « Questions en cours »

Qui est en ligne

Utilisateurs parcourant ce forum : Google [Bot] et 1 invité