version 1.0.2

DESCRIPTION

@@ -0,0 +1,18 @@
+Package: fat2Lpoly
+Type: Package
+Title: Two-locus Family-based Association Test with Polytomic Outcome
+Version: 1.0.2
+Date: 2014-04-02
+Author: Alexandre BUREAU <alexandre.bureau@msp.ulaval.ca> and Jordie Croteau
+        <jordie.croteau@crulrg.ulaval.ca>
+Maintainer: Alexandre BUREAU <alexandre.bureau@msp.ulaval.ca>
+Depends: R (>= 2.10), kinship2, multgee
+Description: Performs family-based association tests with a polytomous outcome under 2-locus and 1-locus models
+             defined by some design matrix.  
+License: GPL
+LazyLoad: yes
+URL: http://www.crulrg.ulaval.ca/pages_perso_chercheurs/bureau_a/
+Packaged: 2014-04-02 18:25:36 UTC; alexandrebureau
+NeedsCompilation: no
+Repository: CRAN
+Date/Publication: 2014-04-02 20:46:07

MD5

@@ -0,0 +1,44 @@
+d4b5a135cf4a518b35946094ac8f72bc *DESCRIPTION
+9b52386444c161cc811b7a0b4ab89b52 *NAMESPACE
+3592877233d6560d023308dd0a3fd8d8 *R/alleles2sums.R
+1d2bad87649bf425fa1a041928da6bda *R/calcule.poids.r
+67e94eddd29101ea32fd2b411c3d829b *R/converti.terme.R
+0752fb5f9b072e2b79b907704097026f *R/cov.score.interfunction.R
+d101ce58abc1a65d1be2081ccbc5d654 *R/cov.score.poly.R
+46486d6840edffe2e694f979af5e1575 *R/design.1locus.R
+9c5e712f2a612002bb5a1b6af767bfa3 *R/design.dichotomique.R
+daaf5e8ca90c2471e5fd7a8ebaf110c3 *R/design.endo2disease.R
+3f0295e3c3e5160a88e2196a983ef433 *R/design.full.R
+c059ba713e7ff77846ca63a7a7254514 *R/design.polytomous.R
+7b7685ed365f885a88a80596885bebf0 *R/fat2Lpoly.R
+6cd60083b431e9a9516309ad062d2e4c *R/fat2Lpoly.withinR.R
+37908df38c6a500601115baedc7b90cd *R/get.scores.pvalues.R
+f0cec50fe70bfe2165f3d6e407b45698 *R/ibd.terms.R
+5fb64df61e924d1d65cf7bb34d7c8693 *R/ibd.terms.w.r
+490de2563d13e3c5a434b6b06561bdd8 *R/produits.paires.R
+94ae3b0fbfa194052069c8631639efb0 *R/read.merlin.files.R
+e5f1e13fd76701a3b2f1fdeae1815546 *R/score.poly.R
+1c7d0fba4236e03ebcb36ff1f0e7944d *R/score.poly.w.r
+6e42ce6c59252441332300a3039accba *R/scores.covs.R
+7e9e225b6f8ce9502c18dbbcb7e034b1 *data/fat2Lpoly.allSNPs.rda
+2f74f4750902b07f284d4597868c6fb7 *data/ped.x.all.rda
+f94acb3141c835660962f00d10d6c446 *inst/extdata/loc1.dat
+276aca53a3d4306e9fa10f41c42800e2 *inst/extdata/loc1.freq
+2f411096480fcaa6cc67e2ee72c308d1 *inst/extdata/loc1.ibd
+203b6add561b8341009de8e81ba6c066 *inst/extdata/loc1.ped
+0ebcc4c539e2d05a9f4296a11bc21fa0 *inst/extdata/loc2.dat
+dfbfbdf6181842b1eabb6fda455f73b2 *inst/extdata/loc2.freq
+c4980b56ecadd8761bc0bb225ba7a53b *inst/extdata/loc2.ibd
+e0809510af61b6e71ce94a53f2b8f950 *inst/extdata/loc2.ped
+2cbec943a544e46a5c82e33bf6a642cc *man/design.1locus.Rd
+4fcd74f42b5576708a1d2ae5cab92e7d *man/design.dichotomous.Rd
+0c267d525689f9a8461f6d5d505db427 *man/design.endo2disease.Rd
+d42ea40ebecaead89a54451f8aef4d8a *man/design.full.Rd
+7586671f01979b130cb4ac70059af627 *man/fat2Lpoly-internal.Rd
+6c473cca57c3db5e5c6e1ccc2a02f26c *man/fat2Lpoly-package.Rd
+31b53cd4ae76d41878593b56f118107f *man/fat2Lpoly.Rd
+36a9184e890e2417fcbba6ea906f9b7f *man/fat2Lpoly.allSNPs.Rd
+68d34011d81783f5cae1a07a1a3a470d *man/fat2Lpoly.withinR.Rd
+6d4e6d2b961025ab859113cbfee882b9 *man/get.scores.pvalues.Rd
+62a125af9f639621bad4cf2980e4f202 *man/ped.x.all.Rd
+0feca94afbe1108dd496b2571d342b3c *man/read.merlin.files.Rd

NAMESPACE

@@ -0,0 +1,2 @@
+import(multgee,kinship2)
+export(design.1locus,design.dichotomous,design.endo2disease,design.full,fat2Lpoly,fat2Lpoly.withinR,get.scores.pvalues,read.merlin.files)

R/alleles2sums.R

@@ -0,0 +1,44 @@
+# Fonction pour convertir un data frame contenant les génotypes (paires d'allèles) de multiples sujets (lignes) et SNPs (paires de colonnes)
+# en un autre data frame contenant, dans le cas allelic, les (nombres d'allèles mineurs)/2 (valeurs 0, 0.5 ou 1; une colonne par SNP);
+# dans le cas dominant, la valeur 1 si le génotype est constitué d'au moins un allèle mineur, 0 sinon;
+# dans le cas récessif, la valeur 1 si le génotype est constitué de 2 allèles mineurs, 0 sinon.
+
+# correspond au fichier alleles2sums_v2.R dans le dossier "programmes"
+
+# par Jordie Croteau
+# 2 juin 2011
+
+alleles2sums=function(geno.table,MA.vec,snp.names,mode="allelic")
+{
+# geno.table : data frame des génotypes (2 colonnes par SNP) 
+# MA.vec :     vecteur des allèles mineurs
+# snp.names :  vecteur des noms de SNPs
+# mode :       mode de transmission ("allelic" (défaut), "recessive" ou "dominant")
+
+num.snps=ncol(geno.table)/2
+geno.table[geno.table==0]=NA 
+
+sums=rep(NA,nrow(geno.table))
+for(j in 1:num.snps){
+cols.tmp=geno.table[,c(-1,0)+2*j]
+cols.tmp.u=unique(as.vector(as.matrix(cols.tmp)))
+if(length(cols.tmp.u[!is.na(cols.tmp.u)])>2) stop(paste("SNP",snp.names[j],"has more than two distinct alleles"))
+sums=data.frame(sums,apply(cols.tmp,1,function(alleles,minor) sum(alleles==minor),minor=MA.vec[j]))
+}
+sums=as.matrix(sums[,-1])
+colnames(sums)=snp.names
+
+if(mode=="allelic") sums=sums/2
+
+if(mode=="recessive"){
+sums[sums==1]=0
+sums[sums==2]=1
+}
+
+if(mode=="dominant") sums[sums==2]=1
+
+sums
+}
+
+
+

R/calcule.poids.r

@@ -0,0 +1,36 @@
+calcule.poids = function(xl,y,ind.par,rep.par,alpha,lc,klc=1)
+# Fonction pour calculer le poids de chaque paire de sujet pour les tests du score conditionnels à un locus
+# d'après l'équation 2 de Chen et al. (2009)
+###################### Définition des arguments #####################################################################################
+# xl : matrice de design pour une famille pour le calcul des covariances
+# ind.par : donne les indices des locus pour la catégorie à laquelle chaque terme appartient
+# lc : locus sur lequel on conditionne le test du score
+# alpha.vec : vecteur de log rapports de cote entre phénotype et compte d'allèle au locus précisé par lc
+#####################################################################################################################################
+  { 
+  ni = dim(xl)[1]
+  w = array(0,c(ni,ni,dim(xl)[3]))
+  kk = 1
+  # Ajout d'un coefficient = 0 pour la catégorie de référence
+  alpha = c(alpha,0)
+#  print(y)
+#  print(alpha)
+  alpha.y = alpha[y]
+  if (klc > 1)
+  {
+  for (k in 1:(klc-1))
+    {
+    kk = kk + rep.par[k]
+    }
+  }
+  # Obtenir l'élément qui contient l'indice du locus lc dans ind.par
+  # Ce locus doit être inclus dans au moins une fonction logistique
+  ilc = ind.par[[kk]][lc]
+  plc = outer(xl[,ilc,klc],xl[,ilc,klc],"-")*outer(alpha.y,alpha.y,"-")
+  wk = 8/ni * exp(plc)/(1+exp(plc))^3
+  # On copie les mêmes poids pour toutes les catégories de réponse
+  for (k in 1:dim(xl)[3])
+    w[,,k] = wk
+  w
+  }
+

R/converti.terme.R

@@ -0,0 +1,9 @@
+
+# correspond au fichier fonction_scores_covs_v2.R (fonction utilitaire à la fin de ce fichier) dans le dossier "programmes"
+
+converti.terme = function(vec,n.loc)
+{
+il = as.numeric(vec)
+ifelse (length(il)>1, n.loc + ifelse(il[1]>1,(il[1] - 1)*(n.loc - il[1]/2),0) + il[2] - il[1],il)     
+}     
+

R/cov.score.interfunction.R

@@ -0,0 +1,46 @@
+# Fonction pour calculer la covariance entre scores pour le même locus mais 
+# des fonctions logit associées à différentes catégories à l'intérieur d'une famille
+# Ceci est une réécriture complète de la fonction pour utiliser les valeurs 
+# déjà calculées par cov.score.poly
+
+# correspond au fichier covariance_score_inter_v3.R dans le dossier "programmes"
+
+
+# Attention! Cette fonction n'est pas en utilisation dans la fonction globale!
+# Il semble qu'on est resté à covariance_score_inter_v2.R
+
+# par Alexandre Bureau
+# version 3
+# mai 2012
+
+# xl.loc : Liste des locus impliqués dans chaque effet
+# ind.cat : donne la catégorie à laquelle appartient chaque paramètre
+# sigma2 : matrice de variance-covariance intra fonction pour une famille
+
+cov.score.interfunction <- function(xl.loc,ind.catl,sigma2)
+{
+n.loc <- max(xl.loc)
+nl <- dim(sigma2)[3] + 1
+if(nl>2)
+{
+
+# Les dimensions de sigmai sont nombre de locus * K-1 * K-1
+sigmai <- array(NA,c(n.loc,nl-1,nl-1))
+
+for (k in 2:(nl-1))
+  {
+  for (l in 1:(k-1))
+    {
+      # On trouve l'intersection des locus présents dans les catégories k et l
+      ll = intersect(xl.loc[ind.catl==k],xl.loc[ind.catl==l])
+      # On prend la moyenne des variances pour les deux catégories
+      # Note: si une variance égale 0 parce qu'il n'y a personne dans la catégorie en question, on ne devrait pas
+      # l'utiliser, mais on laisse faire parce que la covariance sera mise à 0 avec les termes d'IBD
+      # [xl.loc[ind.catl==k] sert à aller chercher les estimations de variance pour les locus dans l'intersection 
+	    sigmai[ll,l,k] <- sigmai[ll,k,l] <- (sigma2[ind.catl==k,k,k][xl.loc[ind.catl==k]%in%ll]+sigma2[ind.catl==l,l,l][xl.loc[ind.catl==l]%in%ll])/2
+    }
+  }
+sigmai
+}
+else NA
+}

R/cov.score.poly.R

@@ -0,0 +1,80 @@
+# Fonction pour calculer la covariance entre scores pour différentes catégories à l'intérieur d'une famille
+
+# correspond au fichier covariance_score_v7.R dans le dossier "programmes"
+
+# par Alexandre Bureau
+# février 2011
+
+# modifs de Jordie, 24 mars 2011 (ajouts de "as.matrix")
+# modifs de Jordie, 22 mai 2012 (remplacement des "as.matrix" par des "array" avec bonnes dimensions)
+# modifs de Jordie, 6 juillet 2012 (simplification du code)
+
+cov.score.poly <- function(x,y,subject.ids=1:length(y),l1,l2,pim,x.loc=rep(1:ncol(pim),nlevels(y)-1))
+{
+# x : tranches de la matrice de design produite par la fonction design.polytomous
+#     qui contient les variables génotypiques d'origine
+# y : vecteur des catégories des sujets, valeur entre 1 et nlevels(y)
+# l1 : liste des 1ers sujets des paires 
+# l2 : liste des 2e sujets des paires
+# pim : matrice des proportion d'IBD inférée pi entre sujets l1 et l2 pour chaque locus dans x
+# x.loc :
+
+y <- as.factor(y)
+if (nlevels(y) != (dim(x)[3] + 1)) stop ("Number of levels of y (",nlevels(y),") is not one more than the 3rd dimension of x (",dim(x)[3],").")
+#ligne suivante à corriger:
+if (length(x.loc) != dim(x)[2]) stop ("Number of variables in x (",dim(x)[2],") does not equal the number of loci listed in x.loc (",length(x.loc),").")
+## Calcul du nombre de sujets par catégorie
+ny <- table(y)
+n <- length(y)
+
+# Détermination des listes de sujets dans chaque catégorie
+# par indices
+indices.par.cat <- tapply(1:n,y,function (vec) vec,simplify=FALSE)
+# par numéro de sujet
+liste.par.cat <- tapply(1:n,y,function (vec) subject.ids[vec],simplify=FALSE)
+
+# Les dimensions de sigmat sont nombre de locus * K-1 * K-1
+sigmat <- array(NA,c(dim(x)[2],dim(x)[3],dim(x)[3]))
+# Calcul de la variance
+for (k in 1:dim(x)[3])
+ {
+	# On fait les calculs seulement s'il y a au moins un sujet dans la catégorie k
+	if (length(liste.par.cat[[k]])>0)
+	  {
+      # Calcul du nombre effectif de paires de sujets (dénominateur de la variance)
+	  dims=c(sum((l1 %in% liste.par.cat[[k]] & !(l2 %in% liste.par.cat[[k]])) | (!(l1 %in% liste.par.cat[[k]]) & l2 %in% liste.par.cat[[k]])),ncol(pim))
+      denom <- 2*(ny[k]*(n-ny[k]) - apply(array(pim[(l1 %in% liste.par.cat[[k]] & !(l2 %in% liste.par.cat[[k]])) | (!(l1 %in% liste.par.cat[[k]]) & l2 %in% liste.par.cat[[k]]),],dims),2,sum))
+      denom <- denom[x.loc]
+	  # Calcul des différences entre paires de sujets
+      tmp <- outer(matrix(x[indices.par.cat[[k]],,k],nrow=length(indices.par.cat[[k]]),ncol=dim(x)[2]),matrix(x[-indices.par.cat[[k]],,k],nrow=dim(x)[1]-length(indices.par.cat[[k]]),ncol=dim(x)[2]),"-")
+
+	  # On somme sur les paires de sujets
+      # Si le dénominateur est 0, on retourne 0
+      sigmat[,k,k] <- ifelse(denom > 1e-10, diag(apply(tmp*tmp,c(2,4),sum))/denom, 0)
+      }	  
+ }
+# Calcul de la covariance
+if((dim(x)[3])>1) #pas de covariance si le nombre de catégories est seulement 2.
+{
+for (k in 2:dim(x)[3])
+  {
+  for (l in 1:(k-1))
+    {
+	  # On fait les calculs seulement s'il y a au moins un sujet dans chacune des catégories k et l
+	  if (length(liste.par.cat[[k]])>0 & length(liste.par.cat[[l]])>0)
+	    {
+	    # Calcul du nombre effectif de paires de sujets (dénominateur de la covariance)
+		dims=c(sum((l1 %in% liste.par.cat[[k]] & l2 %in% liste.par.cat[[l]]) | (l1 %in% liste.par.cat[[l]] & l2 %in% liste.par.cat[[k]])),ncol(pim))
+	    denom <- 2*(ny[k]*ny[l] - apply(array(pim[(l1 %in% liste.par.cat[[k]] & l2 %in% liste.par.cat[[l]]) | (l1 %in% liste.par.cat[[l]] & l2 %in% liste.par.cat[[k]]),],dims),2,sum))
+        denom <- denom[x.loc]
+		# Calcul du produit des différences entre paires de sujets spour dimensions k et l
+        tmp <- outer(matrix(x[indices.par.cat[[k]],,k],nrow=length(indices.par.cat[[k]]),ncol=dim(x)[2]),matrix(x[indices.par.cat[[l]],,k],nrow=length(indices.par.cat[[l]]),ncol=dim(x)[2]),"-")*outer(matrix(x[indices.par.cat[[k]],,l],nrow=length(indices.par.cat[[k]]),ncol=dim(x)[2]),matrix(x[indices.par.cat[[l]],,l],nrow=length(indices.par.cat[[l]]),ncol=dim(x)[2]),"-")
+	    # On somme sur les paires de sujets
+		# Si le dénominateur est 0, on retourne 0
+	    sigmat[,l,k] <- sigmat[,k,l] <- ifelse(denom > 1e-10, diag(apply(tmp,c(2,4),sum))/denom, 0)
+        }
+    }
+  }
+}
+sigmat
+}

R/design.1locus.R

@@ -0,0 +1,28 @@
+# Fonction pour modèle simple à 1 locus avec 4 catégories
+
+# correspond au fichier design_1locus_v3.R dans le dossier "programmes"
+
+
+# par Alexandre Bureau
+
+# modifié par Jordie le 22 août dans le but d'ajouter n.levels (nombre de catégories de la variable réponse) comme attribut de la fonction
+
+design.1locus <- function(x,par.constrained,constraints)
+{
+
+# Matrice avec tous les effets
+
+x.e <- list(x,x,x)
+# Liste des locus impliqués dans chaque effet
+x.loc.e <- list("1","1","1")
+
+# Matrice avec les effets principaux seulement
+x.l <- x.e
+# Liste des locus impliqués dans chaque effet
+x.loc.l <- x.loc.e
+
+# Liste des sorties
+li <- list(x.e=x.e,x.loc.e=x.loc.e,x.l=x.l,x.loc.l=x.loc.l)
+attributes(li)$n.levels <- 4
+li
+}

R/design.dichotomique.R

@@ -0,0 +1,33 @@
+# Fonction pour modèle général avec terme d'interaction
+
+# correspond au fichier design_dichotomique_v4.r dans le dossier "programmes"
+
+
+# Attention! Pour l'instant, on suppose que les contraintes en entrées
+# sont aussi valides en sortie. Il faudra implanter une vérification de ça.
+
+# par Alexandre Bureau
+
+# modifié par Jordie le 22 août dans le but d'ajouter n.levels (nombre de catégories de la variable réponse) comme attribut de la fonction
+
+design.dichotomous <- function(x,...)
+{
+
+# Matrice avec tous les effets
+x1 <- cbind(x[,1],x[,2],x[,1]*x[,2])
+x.e <- list(x1)
+# Liste des locus impliqués dans chaque effet
+x.loc.e <- list("1","2","12")
+
+# Pour ce modèle, x.l est égal à x.e  et  x.loc.l à x.loc.e
+x.l <- x.e
+# Liste des locus impliqués dans chaque effet
+x.loc.l <- x.loc.e
+
+# Liste des sorties
+li <- list(x.e=x.e,x.loc.e=x.loc.e,x.l=x.l,x.loc.l=x.loc.l)
+attributes(li)$n.levels <- 2
+li
+}
+
+

R/design.endo2disease.R

@@ -0,0 +1,41 @@
+# Fonction pour modèle avec contraintes beta3 = -beta2, tau2 = tau3 = 0, gamma2 = 0
+
+# correspond au fichier design_contrainte1_v6.r dans le dossier "programmes"
+
+
+# Attention! Pour l'instant, on suppose que les contraintes en entrées
+# sont aussi valides en sortie. Il faudra implanter une vérification de ça.<
+
+# par Alexandre Bureau
+
+# Modif par Jordie Croteau le 9 septembre 2011: x1 <- cbind(x[,1],x[,2]*(1-x[,1])) devient x1 <- cbind(x[,1],x[,1]*(1-x[,2]))
+
+# modifié par Jordie le 22 août 2012 dans le but d'ajouter n.levels (nombre de catégories de la variable réponse) comme attribut de la fonction
+
+design.endo2disease <- function(x,par.constrained,constraints)
+{
+
+# Matrice avec tous les effets
+#x1 <- cbind(x[,1],x[,2]*(1-x[,1]))
+x1 <- cbind(x[,1],x[,1]*(1-x[,2]))
+x2 <- as.matrix(x[,1])
+x3 <- cbind(x[,1],x[,2]*x[,1])
+x.e <- list(x1,x2,x3)
+# Liste des locus impliqués dans chaque effet
+x.loc.e <- list("1",c("1","12"),"1","1","12")
+
+# Matrice avec les effets principaux seulement
+x1 <- cbind(x[,1],x[,2],x[,2]*x[,1])
+x2 <- as.matrix(x[,1])
+x3 <- cbind(x[,1],x[,2],x[,2]*x[,1])
+x.l <- list(x1,x2,x3)
+# Liste des locus impliqués dans chaque effet
+x.loc.l <- list("1","2","12","1","1","2","12")
+
+# Liste des sorties
+li <- list(x.e=x.e,x.loc.e=x.loc.e,x.l=x.l,x.loc.l=x.loc.l)
+if (!missing(constraints)) li <- list(li,par.constrained=par.constrained,constraints=constraints)
+attributes(li)$n.levels <- 4
+li
+}
+