Nothing
# 1 - gen.gc -> garde article
# 2 - gen.gcplus -> garde article
# 3 - gen.completeness -> garde article
# 4 - gen.completenessVar -> garde article
# 5 - gen.branching -> garde article
# 6 - gen.children -> garde article
# 7 - gen.meangendepth -> garde article
# 8 - gen.entropyMeanVar -> garde article
# 9 - gen.f -> garde article
# 11 - gen.fmean -> garde article
# 12 - gen.founder -> garde article
# 13 - gen.half.founder -> garde article
# 14 - gen.sibship -> garde article
# 16 - gen.genealogy -> garde article
# 17 - gen.lineages -> garde article
# 17-1 gen.genout -> garde article
# 19 - gen.implex -> garde article
# 20 - gen.implexVar -> garde article
# 21 - gen.max -> garde article
# 23 - gen.min -> garde article
# 24 - gen.mean -> garde article
# 25 - gen.nochildren -> garde article
# 26 - gen.nowomen -> garde article
# 27 - gen.nomen -> garde article
# 28 - gen.noind -> garde article
# 32 - gen.occ -> garde article
# 33 - gen.parent -> garde article
# 34 - gen.phi -> garde article
# 35 - gen.phiOver -> garde article
# 37 - gen.phiMean -> garde article
# 41 - gen.depth -> garde article
# 42 - gen.pro -> garde article
# 43 - gen.rec -> garde article
# 44 - gen.meangendepthVar -> garde article
#gen.gc = function(gen, pro = 0, ancestors = 0, typeCG = "IND", named = T, check = 1)
#{
# if(length(check) != 1)
# stop("Invalid 'check' parameter: choices are 0 or 1")
#
# retour = gen.detectionErreur(gen = gen, pro = pro, ancestors = ancestors, print.it = print.it, named = named, typeCG = typeCG,
# check = c(3, 5, 11, 34, 18, 10))
# if(retour$erreur == T) stop(retour$messageErreur)
# gen = retour$gen
# pro = retour$pro
# ancestors = retour$ancestors
# typeCG = retour$typeCG
## print.it = retour$print.it
# named = retour$named
#
# if(typeCG == "IND") {
# if(is(pro, "GLgroup")) {
# CG = GLPrivCG(gen = gen, pro = as.numeric(unlist(pro)), ancestors = ancestors, print.it = FALSE, named = named)
# return(GLPrivCGgroup(CG, grppro = pro))
# }
# else return(GLPrivCG(gen = gen, pro = pro, ancestors = ancestors, print.it = FALSE, named = named))
# }
# else {
# if(is(pro, "GLgroup")) {
# CG = GLPrivCG(gen = gen, pro = as.numeric(unlist(pro)), ancestors = ancestors, print.it = FALSE, named = named)
# CG = GLPrivCGgroup(CG, grppro = pro)
# if(typeCG == "MEAN")
# return(GLPrivCGmoyen(CG = CG, named = named))
# if(typeCG == "CUMUL")
# stop("CUMUL is not available per group")
# if(typeCG == "TOTAL")
# return(GLPrivCGtotal(CG = CG, named = named))
# if(typeCG == "PRODUCT")
# return(GLPrivCGproduit(CG = CG, named = named))
# }
# else {
# CG = GLPrivCG(gen = gen, pro = as.numeric(unlist(pro)), ancestors = ancestors, print.it = FALSE, named =
# named)
# if(typeCG == "MEAN")
# return(GLPrivCGmoyen(CG = CG, named = named))
# if(typeCG == "CUMUL")
# return(GLPrivCGcumul(CG = CG, named = named))
# if(typeCG == "TOTAL")
# return(GLPrivCGtotal(CG = CG, named = named))
# if(typeCG == "PRODUCT")
# return(GLPrivCGproduit(CG = CG, named = named))
# }
# }
#}
gen.gc = function(gen, pro = 0, ancestors = 0, vctProb = c(0.5, 0.5, 0.5, 0.5), typeCG = "IND") #, check = 1)#named = T,
{
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
retour = gen.detectionErreur(gen = gen, pro = pro, ancestors = ancestors, print.it = FALSE, named = TRUE, typeCG = typeCG, check = c(3, 5, 11, 34, 18, 10))
if(retour$erreur == TRUE) stop(retour$messageErreur)
gen = retour$gen
pro = retour$pro
ancestors = retour$ancestors
typeCG = retour$typeCG
# print.it = retour$print.it
named = retour$named
if(typeCG == "IND") {
if(is(pro, "GLgroup")) {
CG = GLPrivCGPLUS(gen = gen, pro = as.numeric(unlist(pro)), ancestors = ancestors, vctProb = vctProb, print.it = FALSE, named = named)
return(GLPrivCGgroup(CG, grppro = pro))
}
else return(GLPrivCGPLUS(gen = gen, pro = pro, ancestors = ancestors, vctProb, print.it = FALSE, named = named))
}
else {
if(is(pro, "GLgroup")) {
CG = GLPrivCGPLUS(gen = gen, pro = as.numeric(unlist(pro)), ancestors = ancestors, vctProb = vctProb, print.it = FALSE, named = named)
CG = GLPrivCGgroup(CG, grppro = pro)
if(typeCG == "MEAN")
return(GLPrivCGmoyen(CG = CG, named = named))
if(typeCG == "CUMUL")
stop("CUMUL is not available per group")
if(typeCG == "TOTAL")
return(GLPrivCGtotal(CG = CG, named = named))
if(typeCG == "PRODUCT")
return(GLPrivCGproduit(CG = CG, named = named))
}
else {
CG = GLPrivCGPLUS(gen = gen, pro = as.numeric(unlist(pro)), ancestors = ancestors, vctProb = vctProb, print.it = FALSE, named = named)
if(typeCG == "MEAN")
return(GLPrivCGmoyen(CG = CG, named = named))
if(typeCG == "CUMUL")
return(GLPrivCGcumul(CG = CG, named = named))
if(typeCG == "TOTAL")
return(GLPrivCGtotal(CG = CG, named = named))
if(typeCG == "PRODUCT")
return(GLPrivCGproduit(CG = CG, named = named))
}
}
}
gen.completeness = function(gen, pro = 0, genNo = -1, type = "MEAN", ...)#, check = 1)#named = T,
{
#Validation des parametres
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
if( type != "IND" )# | type != "MOYSUJETS"
if(is(gen, "vector"))
if(length(list(...)) != 2)
stop("Invalid '...' parameter : 'father' and 'mother' parameter names are obligatory")
#if(check == 1) {
retour <- gen.detectionErreur(gen = gen, pro = pro, genNo = genNo, typecomp = type, named = TRUE, check = c(1, 5, 16, 171, 10))
if(retour$erreur == TRUE)
stop(retour$messageErreur)
gen <- retour$gen
pro <- retour$pro
genNo <- retour$genNo
type <- retour$typecomp
named <- retour$named
#}
#Calcule de la completude par sujet
if(type == "IND"){ # | type == "MOYSUJETS") {
tableau = sapply(pro, function(x, gen, genNo, named)
{
GLPriv.completeness3V(gen$ind, gen$father, gen$mother, pro = x, genNo = genNo, named = named)
}
, gen = gen, genNo = genNo, named = named)
if(is.null(dim(tableau))) tableau <- t(as.matrix(tableau))
# if(type == "MOYSUJETS")
# tableau <- data.frame(apply(tableau, 1, mean))
#Fait la moyenne
#if(named == T)
if(type == "IND")
dimnames(tableau)[[2]] <- as.character(paste("Ind", as.character(pro)))
dimnames(tableau)[[1]] <- as.character(genNo)
#Rajout du numero de generation en lignes
return(data.frame(tableau))
}
else if(type == "MEAN") {
#Si c'est MEAN, calcul de la completude avec tous les sujets a la fois
return(GLPriv.completeness3V(gen$ind, gen$father, gen$mother, pro = pro, genNo = genNo, named = named))
}
}
gen.completenessVar = function(gen, pro = 0, genNo = -1, ...) #, check = 1, ...)#named = T,
{
#Validations des parametres
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
# if(bcorrFactor == T)
# if(sum(N) == 0) #Le facteur de correction doit avoir une valeur numerique N taille de la population
# stop("Correction factor must have a numerical population size value N")
if(is(gen, "vector"))
if(length(list(...)) != 2)
stop("Invalid '...' parameter : 'father' and 'mother' parameter names are obligatory")
retour = gen.detectionErreur(gen = gen, pro = pro, genNo = genNo, named = TRUE, check = c(1, 5, 16, 10))
if(retour$erreur == TRUE) stop(retour$messageErreur)
gen = retour$gen
pro = retour$pro
genNo = retour$genNo
named = retour$named
#Selon le type de donnees, le facteur de correction sera modifie en consequence
# if(typeCorpus == "ECH") corrFactor = length(pro)/(length(pro) - 1) else if(typeCorpus == "POP")
# corrFactor = 1
# if(corrFactor == T)
# corrFactor = (corrFactor * (N - length(pro)))/N
corrFactor = 1
#Calcule la variance de l'indice de completude
tab = sapply(pro, function(x, gen, genNo, named)
GLPriv.completeness3V(gen$ind, gen$father, gen$mother, pro = x, genNo = genNo, named = named),
gen = gen, genNo = genNo, named = named)
if(is.null(dim(tab))) tab <- t(as.matrix(tab))
tab = data.frame(apply(tab, 1, var) * corrFactor)
dimnames(tab)[[1]] <- as.character(genNo)
dimnames(tab)[[2]] <- "completeness.var"
return(tab)
}
gen.branching = function(gen, pro = 0, ancestors = gen.founder(gen), bflag = 0)#, check = 1)
{
if(sum(as.numeric(pro)) == 0)
pro = gen.pro(gen)
if(bflag == 0) {
pro.segment = gen.pro(gen)
ancestors = gen.founder(gen.branching(gen, pro.segment, ancestors, bflag = 1))
}
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
#stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
#if(check == 1) {
retour = gen.detectionErreur(gen = gen, pro = pro, ancestors = ancestors, check = c(3, 36, 37))
if(retour$erreur)
stop(retour$messageErreur)
gen = retour$gen
pro = retour$pro
ancestors = retour$ancestors
#}
#Structure necessaire pour emmagasiner le resultat la fonction de la dll
#print(paste("taille alloue:",length(gen@.Data)))
tmpgen <- integer(length(gen@.Data))
tmpNelem <- integer(1)
#print(".C(SPLUSebranche,.. commence")
.Call("SPLUSebranche", gen@.Data, pro, length(pro), ancestors, length(ancestors), tmpgen, tmpNelem, specialsok = T)
#print(".C(SPLUSebranche,.. fait:")
#print(paste(length(tmpgen),tmpgen[1],tmpgen[2],tmpgen[3] ))
#print(paste(length(gen@.Data),gen@.Data[1],gen@.Data[2],gen@.Data[3]))
length(tmpgen) <- tmpNelem
tmpNelem <- length(tmpgen)
#print(length(tmpgen))
ebranche = new("GLgen", .Data = tmpgen, Date = date())
#print("1")
ebranche.asc = gen.genout(ebranche)
sexeAbsent=FALSE
if(length(setdiff(unique(ebranche.asc[,"sex"]), c(1,2,"H","F")))>0)
{
diff = setdiff(unique(ebranche.asc[,"sex"]), c(1,2,"H","F"))
ebranche.asc=data.frame(ind=ebranche.asc$ind,father=ebranche.asc$father,mother=ebranche.asc$mother) #*****
sexeAbsent=TRUE
#warning(paste("la colonne \"sexe\" contient des valeurs non valide:",diff,"\n Elle ne sera pas consideree pour le reste des calculs."))
warning(paste("The \"sex\" column contains invalid values:",diff,
"\nThe column won't be considered for further calculations."))
}
#print("2")
#print(ebranche.asc[1,])
pro.ebranche = gen.pro(ebranche)
#print("3")
pro.enTrop = setdiff(pro.ebranche, pro)
#print(paste(length(pro.ebranche),length(pro)))
#print(pro.enTrop)
if(sum(as.numeric(pro.enTrop)) != 0) {
ebranche.asc = ebranche.asc[(!(ebranche.asc$ind %in% pro.enTrop)), ]
#ebranche.asc=data.frame(ind=ebranche.asc$ind,father=ebranche.asc$father,mother=ebranche.asc$mother) #*****
ebranche = gen.genealogy(ebranche.asc)
#print(ebranche.asc)
pro.ebranche = gen.pro(ebranche)
}
#print("4")
fond.ebranche = gen.founder(ebranche)
#print("5")
pro.quiSontFond = pro.ebranche[pro.ebranche %in% fond.ebranche]
#print(paste("6", dim(ebranche.asc)))
ebranche.asc = ebranche.asc[(!(ebranche.asc$ind %in% pro.quiSontFond)), ]
#print(paste("7", dim(ebranche.asc)))
#ebranche.asc=data.frame(ind=ebranche.asc$ind,father=ebranche.asc$father,mother=ebranche.asc$mother)#*****
if(dim(ebranche.asc)[1]==0) stop("No branching possible, all probands are founders.")
else gen = gen.genealogy(ebranche.asc)
#print("8")
gen.validationAsc(gen)
#print("9")
return(gen)
}
gen.children = function(gen, individuals, ...)#, check = 1)
{
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
#stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
if(is(gen, "vector"))
if(length(list(...)) != 2)
stop("Invalid '...' parameter : 'father' and 'mother' parameter names are obligatory")
#stop("Param\350tre '...' invalide : indication du nom des param\350tres 'pere' et 'mere' est obligatoire")
#if(check == 1) {
retour = gen.detectionErreur(gen = gen, individuals = individuals, check = c(1, 13), ...)
if(retour$erreur == TRUE)
stop(retour$messageErreur)
gen = retour$gen
individuals = retour$individuals
#}
PositionEnfantDesMeres <- match(gen$mother, individuals)
PositionEnfantDesPeres <- match(gen$father, individuals)
EnfantDesMere <- gen$ind[(1:length(PositionEnfantDesMeres))[!is.na(PositionEnfantDesMeres)]]
EnfantDesPere <- gen$ind[(1:length(PositionEnfantDesPeres))[!is.na(PositionEnfantDesPeres)]]
Enfants <- unique(c(EnfantDesMere, EnfantDesPere))
return(Enfants)
}
gen.meangendepth = function(gen, pro = 0, type = "MEAN", ...)#, check = 1)#named = T,
{
#Validations des parametres
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
#stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
if(is(gen, "vector"))
if(length(list(...)) != 2)
stop("Invalid '...' parameter : 'father' and 'mother' parameter names are obligatory")
#stop("Param\350tre '...' invalide : indication du nom des param\350tres 'pere' et 'mere' est obligatoire")
#if(check == 1) {
retour <- gen.detectionErreur(gen = gen, pro = pro, typecomp = type, check = c(1, 5, 17))
if(retour$erreur == TRUE)
stop(retour$messageErreur)
gen <- retour$gen
pro <- retour$pro
type <- retour$typecomp
#}
if(type == "IND") {# | type == "MOYSUJETS") {
tableau <- sapply(pro, function(x, gen)
GLPriv.entropie3V(gen$ind, gen$father, gen$mother, pro = x), gen = gen)
tableau <- data.frame(tableau)
# if(type == "MOYSUJETS") {
# tableau = data.frame(apply(tableau, 2, mean))
# dimnames(tableau)[[1]] <- "Mean.Exp.Gen.Depth"
# }
#if(named == T)
if(type == "IND")
dimnames(tableau)[[1]] <- as.character(paste("Ind", as.character(pro)))
dimnames(tableau)[[2]] <- "Exp.Gen.Depth"
return(tableau)
}
else if(type == "MEAN")
return(GLPriv.entropie3V(gen$ind, gen$father, gen$mother, pro = pro))
}
#gen.entropyMeanVar = function(gen, pro = 0, check = 1, ...) #typeCorpus = "ECH", bfacteurCorr = F, N = NULL,
#{
# #Validations des parametres
# if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
## if(bfacteurCorr == T)
# if(sum(N) == 0)
## stop("Correction factor must have a numerical population size value N")
# if(is(gen, "vector"))
# if(length(list(...)) != 2)
# stop("Invalid '...' parameter : 'father' and 'mother' parameter names are obligatory")
#
# retour = gen.detectionErreur(gen = gen, pro = pro, check = c(1, 5))
# if(retour$erreur == T) stop(retour$messageErreur)
# gen = retour$gen
# pro = retour$pro
#
# tableau = sapply(pro, function(x, gen)
# GLPriv.entropie3V(gen$ind, gen$father, gen$mother, pro = x), gen = gen)
## if(typeCorpus == "ECH")
## facteurCorr = length(pro)/(length(pro) - 1)
## else if(typeCorpus == "POP")
## facteurCorr = 1
## if(bfacteurCorr == T)
## facteurCorr = (facteurCorr * (N - length(pro)))/N
#
# facteurCorr = 1
# tableau = data.frame(tableau)
# tableau = data.frame(apply(tableau, 2, var) * facteurCorr)
# dimnames(tableau)[[1]] <- "Mean.Exp.Gen.Depth.Var"
# dimnames(tableau)[[2]] <- "Exp.Gen.Depth"
# return(tableau)
#}
#gen.f = function(gen, pro = 0, nbgenerations = 0, named = T, check = 1)
#{
# if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
# retour = gen.detectionErreur(gen = gen, pro = pro, nbgenerations = nbgenerations, print.it = FALSE, named = named, check = c(3, 5, 19, 18, 10))
# if(retour$erreur == T) stop(retour$messageErreur)
# gen = retour$gen
# pro = retour$pro
# nbgenerations = retour$nbgenerations
## print.it = retour$print.it
# named = retour$named
#
# #Structure necessaire pour emmagasiner le resultat la fonction de la dll
# tmp <- double(length(pro))
#
# #Call de la fonction en C
# .Call("SPLUSF", gen@.Data, pro, length(pro), nbgenerations, tmp, FALSE, specialsok = T)
# names(tmp) <- pro
## if(print.it) {
## base <- c(deparse(substitute(gen)), deparse(substitute(pro)), nbgenerations)
## header.txt <- paste("\n\t*** Calls : gen.F (", base[1], ",", base[2], ",", base[3], ") ***\n\n")
## cat(header.txt)
## }
# return(invisible(tmp))
#}
#gen.fmean = function(vectF, named = T, check = 1)
#{
# if(length(check) != 1)
# stop("Invalid 'check' parameter: choices are 0 or 1")
# #stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
# #if(check == 1) {
# retour = gen.detectionErreur(vectF = vectF, named = named, check = c(33, 10))
# if(retour$erreur == T)
# stop(retour$messageErreur)
# vectF = retour$vectF
# named = retour$named
# #}
# #Test pour accelerer la procedure
# return(GLapplyF(vectF, mean, named = named))
#}
gen.founder = function(gen, ...)#, check = 1)
{
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
#stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
if(is(gen, "vector"))
if(length(list(...)) != 2)
stop("Invalid '...' parameter : 'father' and 'mother' parameter names are obligatory")
#stop("Param\350tre '...' invalide : indication du nom des param\350tres 'pere' et 'mere' est obligatoire")
#if(check == 1) {
retour = gen.detectionErreur(gen = gen, ..., check = 1)
if(retour$erreur == TRUE)
return(retour$messageErreur)
gen = retour$gen
#}
return(gen$ind[gen$father == 0 & gen$mother == 0])
}
gen.half.founder = function(gen, ...)#, check = 1)
{
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
#stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
if(is(gen, "vector"))
if(length(list(...)) != 2)
stop("Invalid '...' parameter : 'father' and 'mother' parameter names are obligatory")
#stop("Param\350tre '...' invalide : indication du nom des param\350tres 'pere' et 'mere' est obligatoire")
#if(check == 1) {
retour = gen.detectionErreur(gen = gen, ..., check = 1)
if(retour$erreur == TRUE)
return(retour$messageErreur)
gen = retour$gen
#}
return(gen$ind[(gen$father != 0 & gen$mother == 0) | (gen$father == 0 & gen$mother != 0)])
}
gen.sibship = function(gen, individuals, halfSibling = TRUE, ...)#, check = 1)
{
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
#stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
if(is(gen, "vector"))
if(length(list(...)) != 2)
stop("Invalid '...' parameter : 'father' and 'mother' parameter names are obligatory")
#stop("Param\350tre '...' invalide : indication du nom des param\350tres 'pere' et 'mere' est obligatoire")
#if(check == 1) {
retour = gen.detectionErreur(gen = gen, individuals = individuals, halfSibling = halfSibling, check = c(1, 13, 14), ...)
if(retour$erreur == TRUE) stop(retour$messageErreur)
gen = retour$gen
individuals = retour$individuals
halfSibling = retour$halfSibling
#}
if(halfSibling == TRUE) {
PositionProband = match(individuals, gen$ind)
#Trouve les meres et les peres des probands
Meres <- gen$mother[PositionProband]
Peres <- gen$father[PositionProband]
MaskMere <- Meres != 0
MaskPere <- Peres != 0
Meres <- (Meres/MaskMere)[!is.na(Meres/MaskMere)]
Peres <- (Peres/MaskPere)[!is.na(Peres/MaskPere)]
#Trouve tous les enfants de ces individuals
sibshipMo <- gen.children(gen, individuals = Meres)#, check = 0)
sibshipFa <- gen.children(gen, individuals = Peres)#, check = 0)
#Vecteur contenant tous les enfants incluant les probands
sibshipAndProband <- unique(c(sibshipMo, sibshipFa))
#maintenant on enleve les probands
temp <- match(sibshipAndProband, individuals)
sibship <- sibshipAndProband[(1:length(temp))[is.na(temp)]]
return(sibship)
}
else {
PositionProband = match(individuals, gen$ind)
#Trouve les meres et les peres des probands
Meres <- gen$mother[PositionProband]
Peres <- gen$father[PositionProband]
MaskMere <- Meres != 0
MaskPere <- Peres != 0
Meres <- (Meres/MaskMere)[!is.na(Meres/MaskMere)]
Peres <- (Peres/MaskPere)[!is.na(Peres/MaskPere)]
temp1 <- match(gen$mother, Meres)
temp2 <- match(gen$father, Peres)
PositionsibshipAndProband <- temp1 * temp2
#La sibship incluant les probands
sibshipSameFaMoAndProband <- gen$ind[(1:length(PositionsibshipAndProband))[!is.na(PositionsibshipAndProband)]]
#maintenant enlevons les probands
temp <- match(sibshipSameFaMoAndProband, individuals)
sibship <- sibshipSameFaMoAndProband[(1:length(temp))[is.na(temp)]]
return(sibship)
}
}
gen.f = function(gen, pro, depthmin= (gen.depth(gen)-1), depthmax= (gen.depth(gen)-1)) #, check = 1)#named = T,
{
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
if(missing(pro)) pro = gen.pro(gen)
retour = gen.detectionErreur(gen = gen, pro = pro, depthmin = depthmin, depthmax = depthmax, print.it = FALSE, named = TRUE,
check = c(3, 5, 20, 18, 10))
if(retour$erreur == TRUE) stop(retour$messageErreur)
gen = retour$gen
pro = retour$pro
depthmin = retour$depthmin
depthmax = retour$depthmax
named = retour$named
#Structure necessaire pour emmagasiner le resultat la fonction de la dll
ecart <- as.integer(depthmax) - as.integer(depthmin) + 1
tmp <- double(length(pro) * ecart)
#Call de la fonction en C
.Call("SPLUSFS", gen@.Data, pro, length(pro), depthmin, depthmax, tmp, FALSE, specialsok = TRUE)
#Construction de la matrice de retour
dim(tmp) <- c(length(pro), ecart)
dimnames(tmp) <- list(pro, NULL)
tmp = drop(tmp)
return(invisible(GLmulti(tmp, depth = as.integer(depthmin:depthmax))))
}
gen.genealogy = function(ped, autoComplete=FALSE, ...)#, check = 1)
{
if(!(is(ped, "GLgen"))) {
if(dim(ped)[2]==4 && sum(colnames(ped)==c("X1","X2","X3","X4"))==4) {
print("No column names given. Assuming <ind>, <father>, <mother> and <sex>")
colnames(ped) <- c("ind", "father", "mother", "sex")
}
if(sum(c("ind","father","mother","sex") %in% colnames(ped)) < 4){
stop(paste(paste(c("ind","father","mother","sex")[grep(FALSE,c("ind","father","mother","sex") %in% colnames(ped))]),
"not in table columns.",collapse=""))
}
if(autoComplete & !all(is.element(ped[ped[,"father"]!=0,"father"], ped[,"ind"]))) {
pereManquant <- unique(ped[grep(FALSE, is.element(ped[,"father"], ped[,"ind"])),"father"])
pereManquant <- pereManquant[-grep("^0$",pereManquant)]
ajout <- matrix(c(pereManquant, rep(0, (2*length(pereManquant))), rep(1,length(pereManquant))), byrow=FALSE, ncol=4)
colnames(ajout) <- colnames(ped)
ped <- rbind(ped, ajout)
}
if(autoComplete & !all(is.element(ped[ped[,"mother"]!=0,"mother"], ped[,"ind"]))) {
mereManquante <- unique(ped[grep(FALSE, is.element(ped[,"mother"], ped[,"ind"])),"mother"])
mereManquante <- mereManquante[-grep("^0$",mereManquante)]
ajout <- matrix(c(mereManquante, rep(0, (2*length(mereManquante))), rep(2,length(mereManquante))), byrow=FALSE, ncol=4)
colnames(ajout) <- colnames(ped)
ped <- rbind(ped, ajout)
}
}
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
retour = gen.detectionErreur(gen = ped, check = 1, ...)
if(retour$erreur == TRUE) stop(retour$messageErreur)
gen = retour$gen
tmp2 <- NULL
if(!is.null(gen$sex)) {
tmp <- factor(gen$sex, levels = c("H", "h", 1, "F", "f", 2))
tmp2 <- as(tmp, "integer")
tmp2[tmp2 == 2 | tmp2 == 3] <- 1
tmp2[tmp2 == 4 | tmp2 == 5 | tmp2 == 6] <- 2
}
n <- .Call("SPLUSCALLCreerObjetGenealogie", gen$ind, gen$father, gen$mother, tmp2)
#Creation de l'objet Genealogie
return(new("GLgen", .Data = n, Date = date()))
}
gen.lineages = function(ped, pro = 0, maternal = TRUE, ...)#, check = 1
{
#Creation d'un objet GLgen avec toutes les ascendances
gen = gen.genealogy(ped, ...) #check = check,
#Validation des parametres gen et proband
retour = gen.detectionErreur(gen = gen, pro = pro, check = c(3, 36))
if(retour$erreur == TRUE) stop(retour$messageErreur)
gen = retour$gen
pro = retour$pro
#Si des sujets ne sont pas forces, par defaut les individuals n'ayant pas d'enfants sont selectionnes
if(sum(pro == 0)) data.ind = gen.pro(gen) else data.ind = pro
#Si c'est des lignees maternelles, les tous les peres sont mis a 0, sinon c'est les meres
if(maternal == TRUE) {
ped$father = rep(0, length(ped$father))
# output = "M"
}
else {
ped$mother = rep(0, length(ped$mother))
# output = "F"
}
#On cree un objet GLgen avec les meres ou les peres a 0
genMouP = gen.genealogy(ped, ...) #, check = check
lig.parent.lst = c(data.ind)
#Pour toutes les depths, on prend les parents a partir des sujets
for(i in 1:gen.depth(gen)) {
data.ind = unlist(gen.parent(genMouP, data.ind))
lig.parent.lst = c(lig.parent.lst, data.ind)
}
#Du resultat, on extrait les individuals de la table d'ascendances qui sont presents
gen = gen.genealogy(ped[(ped$ind %in% lig.parent.lst), ], ...) #, check = check
#Retourne l'objet GLgen de lignees
return(gen)
}
gen.genout = function(gen, sorted = FALSE)#, check = 1)
{
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
#stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
#if(check == 1) {
retour = gen.detectionErreur(gen = gen, sorted = sorted, check = c(3, 4))
if(retour$erreur == TRUE) stop(retour$messageErreur)
gen = retour$gen
sorted = retour$sorted
#}
#Structure necessaire pour emmagasiner le resultat la fonction de la dll
#print(paste(" ? ",gen@.Data[9]))
taille <- gen.noind(gen)
v <- list(ind = integer(taille), father = integer(taille), mother = integer(taille), sex = integer(taille))
#extern "C" void SPLUSOutgen
#(long* genealogie, long* plRetIndividu,long* plRetPere,long* plRetMere,long* mustsort)
#param <- list(Data=gen@.Data, ind=v$ind, father=v$father, mother=v$mother, sex=v$sex, sorted=sorted)
#param = .Call("SPLUSOutgen", param, NAOK = T)
param = .Call("SPLUSOutgen", gen@.Data, v$ind, v$father, v$mother, v$sex, sorted)
v <- list(ind = param$ind, father = param$father, mother = param$mother, sex = param$sex)
#Si le numero du sex (0 ou 1 )des individuals est present, on les change pour "H" ou "F"
#if(v$sex[1] == -1) v <- v[1:3]
#else v[[4]] <- factor(v[[4]], labels = c("H", "F"))
return(invisible(data.frame(v)))
}
gen.implex = function(gen, pro = 0, genNo = -1, type = "MEAN", onlyNewAnc = FALSE, ...)#, check = 1 named = T,
{
#Validations des parametres
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
#stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
if(is(gen, "vector"))
if(length(list(...)) != 2)
stop("Invalid '...' parameter : 'father' and 'mother' parameter names are obligatory")
#stop("Param\350tre '...' invalide : indication du nom des param\350tres 'pere' et 'mere' est obligatoire")
#if(check == 1) {
retour <- gen.detectionErreur(gen = gen, pro = pro, genNo = genNo, typecomp = type, named = TRUE, check = c(1, 5, 16, 17, 10))
if(retour$erreur == TRUE)
stop(retour$messageErreur)
gen <- retour$gen
pro <- retour$pro
genNo <- retour$genNo
named <- retour$named
type <- retour$typecomp
#}
#Les ancetres se repetent sur plusieurs generations
#Si on veut les ancetres distincts par generation nouveaux ou pas la fonctionnalite utilisee sera differente
if(onlyNewAnc == FALSE) fctApp <- GLPriv.implex3V else fctApp <- gen.implex3V
#Les ancetres ne sont comptes qu'a leur 1ere apparition
#Selon le type du calcul
#Calcule de l'implex par sujet
if(type == "IND" | type == "MEAN") {
tableau = sapply(pro, function(x, gen, genNo, fctApp, named)
{
fctApp(gen$ind, gen$father, gen$mother, pro = x, genNo = genNo, named = named)
}
, gen = gen, genNo = genNo, fctApp = fctApp, named = named)
if(is.null(dim(tableau))) tableau <- t(as.matrix(tableau))
#Selon le resultat, on applique au tableau une operation de moyenne ou pas
if(type == "MEAN") tableau = data.frame(apply(tableau, 1, mean))
#if(named == T)
#dimnames(tableau)[[2]] <- "implex"
names(tableau) <- "implex"
if(type == "IND") dimnames(tableau)[[2]] <- as.character(paste("Ind", as.character(pro)))
dimnames(tableau)[[1]] <- as.character(genNo)
return(data.frame(tableau))
}
else if(type == "ALL")
return(fctApp(gen$ind, gen$father, gen$mother, pro = pro, genNo = genNo, named = named))
}
gen.implexVar = function(gen, pro = 0, onlyNewAnc = FALSE, genNo = -1, ...)# check = 1,named = T,
{
#Validation des parametres
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
# if(bfacteurCorr == T)
# if(sum(N) == 0)
# stop("Correction factor must have a numerical population size value N")
if(is(gen, "vector"))
if(length(list(...)) != 2)
stop("Invalid '...' parameter : 'father' and 'mother' parameter names are obligatory")
retour = gen.detectionErreur(gen = gen, pro = pro, genNo = genNo, named = TRUE, check = c(1, 5, 16, 10))
if(retour$erreur == TRUE) stop(retour$messageErreur)
gen = retour$gen
pro = retour$pro
genNo = retour$genNo
named = retour$named
#Si on veut les ancetres distincts par generation nouveaux ou pas la fonctionnalite utilisee sera differente
if(onlyNewAnc == FALSE) fctApp <- GLPriv.implex3V else fctApp <- gen.implex3V
#Selon le type de donnees, le facteur de correction sera modifie en consequence
# if(typeCorpus == "ECH") facteurCorr = length(pro)/(length(pro) - 1) else if(typeCorpus == "POP")
# facteurCorr = 1
# if(bfacteurCorr == T)
# facteurCorr = (facteurCorr * (N - length(pro)))/N
facteurCorr = 1
tableau = sapply(pro, function(x, gen, fctApp, genNo, named) {
fctApp(gen$ind, gen$father, gen$mother, pro = x, genNo = genNo, named = named)
}, gen = gen, fctApp = fctApp, genNo = genNo, named = named)
if(is.null(dim(tableau))) tableau <- t(as.matrix(tableau))
tableau = data.frame(apply(tableau, 1, var) * facteurCorr)
dimnames(tableau)[[1]] <- as.character(genNo)
dimnames(tableau)[[2]] <- "implex.var"
return(tableau)
}
#gen.max = function(gen, individuals, named = T, check = 1)
#{
# #On appel la fonction qui permet d'avoir
# #le numero de generation de tout les individuals
# dfData.numgen = gen.generation(gen, as.integer(individuals))
# dfResult = as.data.frame(as.numeric(names(dfData.numgen))) #named.index.rowcol( dfData.numgen, "numeric")
# dfResult[, 2] = dfData.numgen
# dimnames(dfResult)[[2]] <- c("ind", "numgen")
# return(dfResult)
#}
gen.max = function(gen, individuals)#, check = 1) #, ancestors=0)named = T,
{
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
retour = gen.detectionErreur(gen = gen, individuals = individuals, ancestors = 0, named = TRUE, check = c(3, 13, 10))
if(retour$erreur == TRUE) stop(retour$messageErreur)
gen = retour$gen
individuals = retour$individuals
named = retour$named
#Structure necessaire pour emmagasiner le resultat la fonction de la dll
nPro = length(individuals)
ret = integer(nPro)
#extern "C" void SPLUSnumeroGen(long* Genealogie, long* lpProband, NProband, retour)
.Call("SPLUSnumeroGen", gen@.Data, as.integer(individuals), nPro, ret)
#if(named)
names(ret) <- individuals
return(ret)
}
gen.min = function(gen, individuals)#, check = 1) #, ancestors=0)named = T,
{
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
#stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
#if(check == 1) {
retour = gen.detectionErreur(gen = gen, individuals = individuals, ancestors = 0, named = TRUE, check = c(3,13,10))
if(retour$erreur == TRUE)
stop(retour$messageErreur)
gen = retour$gen
individuals = retour$individuals
named = retour$named
#}
#Structure necessaire pour emmagasiner le resultat la fonction de la dll
nPro = length(individuals)
ret = integer(nPro)
#extern "C" void SPLUSnumeroGen(long* Genealogie, long* lpProband, NProband, retour)
.Call("SPLUSnumGenMin", gen@.Data, as.integer(individuals), nPro, ret)
#if(named)
names(ret) <- individuals
return(ret)
}
gen.mean = function(gen, individuals)#, check = 1) #, ancestors=0)named = T,
{
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
#stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
#if(check == 1) {
retour = gen.detectionErreur(gen = gen, individuals = individuals, ancestors = 0, named = TRUE, check = c(3,13,10))
if(retour$erreur == TRUE)
stop(retour$messageErreur)
gen = retour$gen
individuals = retour$individuals
named = retour$named
#}
#Structure necessaire pour emmagasiner le resultat la fonction de la dll
nPro = length(individuals)
ret = double(nPro)
#extern "C" void SPLUSnumeroGen(long* Genealogie, long* lpProband, NProband, retour)
.Call("SPLUSnumGenMoy", gen@.Data, as.integer(individuals), nPro, ret)
#if(named)
names(ret) <- individuals
return(ret)
}
gen.nochildren = function(gen, individuals)#, check = 1)#named = T,
{
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
#stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
#if(check == 1) {
retour = gen.detectionErreur(gen = gen, individuals = individuals, named = TRUE, check = c(3, 13, 10))
if(retour$erreur == TRUE)
stop(retour$messageErreur)
gen = retour$gen
individuals = retour$individuals
named = retour$named
#}
#Structure necessaire pour emmagasiner le resultat la fonction de la dll
ret <- integer(length(individuals))
#extern "C" void SPLUSChild(long* Genealogie, long* plProband,long* lNProband, long* retour)
.Call("SPLUSChild", gen@.Data, individuals, length(individuals), ret, specialsok = TRUE)
#if(named)
names(ret) <- individuals
return(ret)
}
gen.nowomen = function(gen)#, check = 1)
{
#if(length(check) != 1)stop("Invalid 'check' parameter: choices are 0 or 1")
#stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
#if(check == 1) {
retour = gen.detectionErreur(gen = gen, check = 3)
if(retour$erreur == TRUE)
stop(retour$messageErreur)
gen = retour$gen
#}
if(gen@.Data[12] == -1) return(NA)
return(gen@.Data[9] - gen@.Data[12])
}
gen.nomen = function(gen)#, check = 1)
{
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
#stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
#if(check == 1) {
retour = gen.detectionErreur(gen = gen, check = 3)
if(retour$erreur == TRUE)
stop(retour$messageErreur)
gen = retour$gen
#}
if(gen@.Data[12] == -1) return(NA)
return(gen@.Data[12])
}
gen.noind = function(gen)#, check = 1)
{
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
#stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
#if(check == 1) {
retour = gen.detectionErreur(gen = gen, check = c(3))
if(retour$erreur == TRUE)
stop(retour$messageErreur)
gen = retour$gen
#}
return(gen@.Data[9])
}
gen.occ = function(gen, pro = 0, ancestors = 0, typeOcc = "IND", ...) # check = 1,
{
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
#stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
if(is(gen, "vector"))
if(length(list(...)) != 2)
stop("Invalid '...' parameter : 'father' and 'mother' parameter names are obligatory")
#stop("Param\350tre '...' invalide : indication du nom des param\350tres 'pere' et 'mere' est obligatoire")
#if(check == 1) {
retour = gen.detectionErreur(gen, pro = pro, ancestors = ancestors, check = c(1, 5, 11), ...)
if(retour$erreur == TRUE)
stop(retour$messageErreur)
gen = retour$gen
pro = retour$pro
ancestors = retour$ancestors
#}
#Les probands sont consideres individuellement
#Les probands sont divises en groupe
if(is(pro, "GLgroup")) {
occurences <- matrix(0, nrow = length(ancestors), ncol = length(pro))
for(i in 1:length(pro))
occurences[, i] <- GLPrivOcc(gen, pro = pro[[i]], ancestors = ancestors)
dimnames(occurences) <- list(ancestors, names(pro))
return(occurences)
}
else {
occurences <- matrix(0, nrow = length(ancestors), ncol = length(pro))
for(i in 1:length(pro))
occurences[, i] <- GLPrivOcc(gen, pro = pro[i], ancestors = ancestors)
dimnames(occurences) <- list(ancestors, pro)
if(typeOcc == "IND")
return(occurences)
else if(typeOcc == "TOTAL") {
dfResult.occtot = data.sum(as.data.frame(occurences))
dimnames(dfResult.occtot)[[1]] <- dimnames(occurences)[[1]]
dimnames(dfResult.occtot)[[2]] <- c("nb.occ")
return(dfResult.occtot)
}
else
print("Please choose between \"IND\" and \"TOTAL\" for the variable typeOcc.")
}
}
gen.parent = function(gen, individuals, output = "FaMo", ...)#, check = 1
{
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
#stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
if(is(gen, "vector"))
if(length(list(...)) != 2)
stop("Invalid '...' parameter : 'father' and 'mother' parameter names are obligatory")
#stop("Param\350tre '...' invalide : indication du nom des param\350tres 'pere' et 'mere' est obligatoire")
#if(check == 1) {
retour = gen.detectionErreur(gen = gen, individuals = individuals, output = output, check = c(1, 13, 15), ...)
if(retour$erreur == TRUE)
stop(retour$messageErreur)
gen = retour$gen
individuals = retour$individuals
output = retour$output
#}
PositionProband = match(individuals, gen$ind)
Meres <- gen$mother[PositionProband]
Peres <- gen$father[PositionProband]
Meres <- Meres[!is.na(Meres)]
Peres <- Peres[!is.na(Peres)]
Meres <- unique(Meres)
Peres <- unique(Peres)
if(output == "FaMo")
return(list(Fathers=Peres[Peres > 0], Mothers=Meres[Meres > 0]))
else if(output == "Fa")
return(Peres[Peres > 0])
else if(output == "Mo")
return(Meres[Meres > 0])
}
#gen.phi = function(gen, pro = 0, nbgenerations = 0, print.it = F, named = T, check = 1)
#{
# if(length(check) != 1)
# stop("Invalid 'check' parameter: choices are 0 or 1")
# #stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
# #if(check == 1) {
# retour = gen.detectionErreur(gen = gen, pro = pro, nbgenerations = nbgenerations, print.it = print.it, named =
# named, check = c(3, 5, 19, 18, 10))
# if(retour$erreur == T)
# stop(retour$messageErreur)
# if(length(retour$pro) < 2)
# stop("Invalid 'pro' parameter: must be a numerical vector of at least 2 proband")
# #stop("Param\350tre 'prop' invalide: doit \352tre un vecteur num\351rique de 2 proposants minimum")
# gen = retour$gen
# pro = retour$pro
# nbgenerations = retour$nbgenerations
# print.it = retour$print.it
# named = retour$named
# #}
# #Structure necessaire pour emmagasiner le resultat la fonction de la dll
# tmp <- double(length(pro) * length(pro))
# #extern "C" void SPLUSPhiMatrix(long* Genealogie,long* proband, long *NProband,long *Niveau,double* pdRetour, long *printit)
# #Call de la fonction en C
# .Call("SPLUSPhiMatrix", gen@.Data, pro, length(pro), as.integer(nbgenerations), tmp, print.it, specialsok = T)
# dim(tmp) <- c(length(pro), length(pro))
# #if(named)
# dimnames(tmp) <- list(pro, pro)
# if(print.it) {
# base <- c(deparse(substitute(gen)), deparse(substitute(pro)), nbgenerations)
# header.txt <- paste("*** Calls : gen.phi (", base[1], ",", base[2], ",", base[3], ") ***")
# cat(header.txt, "\n")
# }
# return(invisible(tmp))
#}
gen.phiOver = function(phiMatrix, threshold)
{
if(!is.matrix(phiMatrix))
return("erreur on doit avoir une matrice")
n = dim(phiMatrix)[1]
phiMatrix[phiMatrix >= 0.5] = 0
phiMatrix[lower.tri(phiMatrix)] = 0
ind = dimnames(phiMatrix)[[1]]
indices = matrix(rep(1:n, each = n), n, n)
ran = indices[phiMatrix >= threshold]
col = t(indices)[phiMatrix >= threshold]
if(is.null(ind))
ind = 1:n
else ind = as.numeric(ind)
data.frame(line = ran, column = col, pro1 = ind[ran], pro2 = ind[col], kinship = phiMatrix[phiMatrix >= threshold])
}
gen.phiMean = function(phiMatrix)#, check = 1)#named = T,
{
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
#stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
#if(check == 1) {
retour = gen.detectionErreur(matricephi = phiMatrix, named = TRUE, check = c(28, 10))
if(retour$erreur == TRUE)
stop(retour$messageErreur)
phiMatrix = retour$matricephi
named = retour$named
#}
#Test pour accelerer la procedure
if("matrix" %in% class(phiMatrix))
mean(phiMatrix[phiMatrix < 0.5])
else
GLapplyPhi(phiMatrix, function(x) mean(x[x < 0.5]), named = named)
}
#gen.phiMT = function(gen, pro = 0, nbgenerations = 0, print.it = F, named = T, check = 1)
#{
# if(length(check) != 1)
# stop("Invalid 'check' parameter: choices are 0 or 1")
# #stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
# #if(check == 1) {
# retour = gen.detectionErreur(gen = gen, pro = pro, nbgenerations = nbgenerations, print.it = print.it, named = named, check = c(3, 5, 19, 18, 10))
# if(retour$erreur == T)
# return(retour$messageErreur)
# gen = retour$gen
# pro = retour$pro
# nbgenerations = retour$nbgenerations
# print.it = retour$print.it
# named = retour$named
# #}
# #Structure necessaire pour emmagasiner le resultat la fonction de la dll
# tmp <- double(length(pro) * length(pro))
# #extern "C" void SPLUSPhiMatrixMT(long* Genealogie,long* proband,long *NProband,long *Niveau,double* pdRetour, long *printit)
# .Call("SPLUSPhiMatrixMT", gen@.Data, pro, length(pro), as.integer(nbgenerations), tmp, print.it, specialsok = T)
# dim(tmp) <- c(length(pro), length(pro))
# #if(named)
# dimnames(tmp) <- list(pro, pro)
# if(print.it) {
# base <- c(deparse(substitute(gen)), deparse(substitute(pro)), nbgenerations)
# header.txt <- paste("*** Calls : gen.phiMT (", base[1], ",", base[2], ",", base[3], ") ***")
# cat(header.txt, "\n")
# }
# return(invisible(tmp))
#}
gen.phi = function(gen, pro, depthmin = (gen.depth(gen)-1), depthmax = (gen.depth(gen)-1), MT = FALSE)#, check = 1)#named = T,
{
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
if(missing(pro)) pro = gen.pro(gen)
if( depthmin<0 | depthmin>(gen.depth(gen)-1) | depthmax<0 | depthmax>(gen.depth(gen)-1) )
stop("depthmin and depthmax must be between 0 and (gen.depth(gen)-1)")
retour = gen.detectionErreur( gen=gen, pro=pro, depthmin=depthmin, depthmax=depthmax, print.it=FALSE, named=TRUE, check=c(3,5,20,18,10))
if(retour$erreur == TRUE) stop(retour$messageErreur)
gen = retour$gen
pro = retour$pro
depthmin = retour$depthmin
depthmax = retour$depthmax
# print.it = retour$print.it
named = retour$named
#a faire un peu plus tard
if(MT) {
ecart <- as.integer(depthmax) - as.integer(depthmin) + 1
np <- length(pro)
npp <- length(pro) * length(pro)
#Structure necessaire pour emmagasiner le resultat la fonction de la dll
rmatrix <- double(ecart * npp)
moyenne <- double(ecart)
.Call("SPLUSPhisMT", gen@.Data, pro, length(pro), as.integer(depthmin), as.integer(depthmax), moyenne, rmatrix, FALSE, specialsok=TRUE)
}
else {
# depthmaxtmp = depthmax
# depthmintmp = depthmin
liste = list()
j = 1
for(i in depthmin:depthmax) {
depthmintmp = i
depthmaxtmp = i
ecart <- as.integer(depthmaxtmp) - as.integer(depthmintmp) + 1
np <- length(pro)
#Structure necessaire pour emmagasiner le resultat la fonction de la dll
npp <- length(pro) * length(pro)
rmatrix <- double(ecart * npp)
moyenne <- double(ecart)
print.it=FALSE
.Call("SPLUSPhis", gen@.Data, pro, length(pro), depthmintmp, depthmaxtmp, moyenne, rmatrix, print.it, specialsok = TRUE)
dim(rmatrix) <- c(np, np, ecart)
dimnames(rmatrix) <- list(pro, pro, NULL)
rmatrix <- drop(rmatrix)
# if(print.it) {
# base <- c(deparse(substitute(gen)), deparse(substitute(pro)), depthmintmp, depthmaxtmp)
# header.txt <- paste("*** Calls : gen.phis (", base[1], ",", base[2], ",", base[3], ",", base[4], ") ***")
# cat(header.txt, "\n")
# }
liste[[j]] = rmatrix
j = j + 1
}
sortie.lst = c()
for(i in 1:length(liste)) sortie.lst = c(sortie.lst, liste[[i]])
ecart <- as.integer(depthmax) - as.integer(depthmin) + 1
np <- length(pro)
#Structure necessaire pour emmagasiner le resultat la fonction de la dll
npp <- length(pro) * length(pro)
rmatrix <- double(ecart * npp)
rmatrix <- sortie.lst
}
dim(rmatrix) <- c(np, np, ecart)
dimnames(rmatrix) <- list(pro, pro, NULL)
rmatrix <- drop(rmatrix)
return(invisible(GLmulti(rmatrix, depth = as.integer(depthmin:depthmax))))
}
# print.it = F,
#gen.phis = function(gen, depthmin, depthmax, pro, named = T, check = 1)
#{
# if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
# if(missing(pro)) pro = gen.pro(gen)
#
# retour = gen.detectionErreur(gen=gen,pro=pro,depthmin=depthmin,depthmax=depthmax,print.it=FALSE,named=named,check=c(3,5,20,18,10))
# if(retour$erreur == T) stop(retour$messageErreur)
# gen = retour$gen
# pro = retour$pro
# depthmin = retour$depthmin
# depthmax = retour$depthmax
## print.it = retour$print.it
# named = retour$named
#
# #a faire un peu plus tard
# depthmaxtmp = depthmax
# depthmintmp = depthmin
# liste = list()
# j = 1
# for(i in depthmintmp:depthmaxtmp) {
# depthmin = i
# depthmax = i
# ecart <- as.integer(depthmax) - as.integer(depthmin) + 1
# np <- length(pro)
# #Structure necessaire pour emmagasiner le resultat la fonction de la dll
# npp <- length(pro) * length(pro)
# rmatrix <- double(ecart * npp)
# moyenne <- double(ecart)
# .Call("SPLUSPhis", gen@.Data, pro, length(pro), depthmin, depthmax, moyenne, rmatrix, print.it, specialsok = T)
# dim(rmatrix) <- c(np, np, ecart)
# dimnames(rmatrix) <- list(pro, pro, NULL)
# rmatrix <- drop(rmatrix)
# if(print.it) {
# base <- c(deparse(substitute(gen)), deparse(substitute(pro)), depthmin, depthmax)
# header.txt <- paste("*** Calls : gen.phis (", base[1], ",", base[2], ",", base[3], ",", base[4], ") ***")
# cat(header.txt, "\n")
# }
# liste[[j]] = rmatrix
# j = j + 1
# }
# sortie.lst = c()
# for(i in 1:length(liste))
# sortie.lst = c(sortie.lst, liste[[i]])
# ecart <- as.integer(depthmaxtmp) - as.integer(depthmintmp) + 1
# np <- length(pro)
# #Structure necessaire pour emmagasiner le resultat la fonction de la dll
# npp <- length(pro) * length(pro)
# rmatrix <- double(ecart * npp)
# rmatrix <- sortie.lst
# dim(rmatrix) <- c(np, np, ecart)
# #if(named)
# dimnames(rmatrix) <- list(pro, pro, NULL)
# rmatrix <- drop(rmatrix)
# return(invisible(GLmulti(rmatrix, depth = as.integer(depthmintmp:depthmaxtmp))))
#}
#gen.phisMT = function(gen, depthmin, depthmax, pro, print.it = F, named = T, check = 1)
#{
# if(length(check) != 1)
# stop("Invalid 'check' parameter: choices are 0 or 1")
# #stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
# if(missing(pro))
# pro = gen.pro(gen)
# #if(check == 1) {
# retour = gen.detectionErreur(gen = gen, pro = pro, depthmin = depthmin, depthmax = depthmax, print.it = print.it,
# named = named, check = c(3, 5, 20, 18, 10))
# if(retour$erreur == T)
# stop(retour$messageErreur)
# gen = retour$gen
# pro = retour$pro
# depthmin = retour$depthmin
# depthmax = retour$depthmax
# print.it = retour$print.it
# named = retour$named
# #}
# #a faire un peu plus tard
# ecart <- as.integer(depthmax) - as.integer(depthmin) + 1
# np <- length(pro)
# npp <- length(pro) * length(pro)
# #Structure necessaire pour emmagasiner le resultat la fonction de la dll
# rmatrix <- double(ecart * npp)
# moyenne <- double(ecart)
# #extern "C" void SPLUSPhis(long* Genealogie,long* proband, long *NProband,long *NiveauMin,long *NiveauMax,double* pdRetour, double *MatrixArray, long *printit)
# .Call("SPLUSPhisMT", gen@.Data, pro, length(pro), as.integer(depthmin), as.integer(depthmax), moyenne, rmatrix, print.it, specialsok = T)
# dim(rmatrix) <- c(np, np, ecart)
# #if(named)
# dimnames(rmatrix) <- list(pro, pro, NULL)
# rmatrix <- drop(rmatrix)
# if(print.it) {
# base <- c(deparse(substitute(gen)), deparse(substitute(pro)), depthmin, depthmax)
# header.txt <- paste("*** Calls : gen.phis (", base[1], ",", base[2], ",", base[3], ",", base[4], ") ***")
# cat(header.txt, "\n")
# }
# return(invisible(GLmulti(rmatrix, depth = as.integer(depthmin:depthmax))))
#}
gen.depth = function(gen)
{
return(depth(gen))
}
gen.pro = function(gen, ...) #, check = 1
{
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
#stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
if(is(gen, "vector"))
if(length(list(...)) != 2)
stop("Invalid '...' parameter : 'father' and 'mother' parameter names are obligatory")
#stop("Param\350tre '...' invalide : indication du nom des param\350tres 'pere' et 'mere' est obligatoire")
#print("genPro : 1e verifications faites")
#if(check == 1) {
retour = gen.detectionErreur(gen = gen, check = 1, ...)
#return(1)
if(retour$erreur)
return(retour$messageErreur)
gen = retour$gen
#print(paste("genPro",retour$erreur))
#}
#print(paste("gen.pro post",length(gen$ind)))
#print(paste("gen.pro post",length(gen$father)))
#print(paste("gen.pro post",length(gen$mother)))
#print(paste("gen.pro post",length(gen$sex)))
return(sort(gen$ind[is.na(match(gen$ind, c(gen$father, gen$mother)))]))
}
gen.rec = function(gen, pro = 0, ancestors = 0, ...) #, check = 1
{
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
#stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
if(is(gen, "vector"))
if(length(list(...)) != 2)
stop("Invalid '...' parameter : 'father' and 'mother' parameter names are obligatory")
#stop("Param\350tre '...' invalide : indication du nom des param\350tres 'pere' et 'mere' est obligatoire")
#if(check == 1) {
retour = gen.detectionErreur(gen = gen, pro = pro, ancestors = ancestors, check = c(1, 5, 11), ...)
if(retour$erreur == TRUE)
stop(retour$messageErreur)
gen = gen.genealogy(retour$gen)#, check = 0)
pro = retour$pro
ancestors = retour$ancestors
#}
if(is(pro, "GLgroup")) {
nombreAncetre <- length(ancestors)
nombreGroupe <- length(pro)
rec <- matrix(0, nrow = nombreAncetre, ncol = nombreGroupe)
for(i in 1:nombreGroupe) {
contr <- t(gen.gc(gen, pro[[i]], ancestors))
rec[, i] <- (contr > 0) %*% rep(1, dim(contr)[2])
}
dimnames(rec) <- list(ancestors, names(pro))
return(rec)
}
else {
contr <- t(gen.gc(gen, pro, ancestors))
recouv <- (contr > 0) %*% rep(1, dim(contr)[2])
return(recouv)
}
}
gen.meangendepthVar = function(gen, pro = 0, type = "MEAN", ...)#, check = 1, named = T,
{
#Validation des parametres
#if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
if(is(gen, "vector"))
if(length(list(...)) != 2)
stop("Invalid '...' parameter : 'father' and 'mother' parameter names are obligatory")
retour <- gen.detectionErreur(gen = gen, pro = pro, typecomp = type, check = c(1, 5, 17))
if(retour$erreur == TRUE) stop(retour$messageErreur)
gen <- retour$gen
pro <- retour$pro
type <- retour$typecomp
if(type == "IND") {# | type == "MOYSUJETS") {
tableau <- sapply(pro, function(x, gen, pro, genNo, T)
GLPriv.variance3V(gen$ind, gen$father, gen$mother, pro = x), gen = gen, pro = pro)
tableau <- data.frame(tableau)
# if(type == "MOYSUJETS") {
# tableau <- data.frame(apply(tableau, 2, mean))
# dimnames(tableau)[[1]] <- "Mean.Exp.Gen.Depth"
# }
if(type == "IND")
dimnames(tableau)[[1]] <- as.character(paste("Ind", as.character(pro)))
dimnames(tableau)[[2]] <- "Mean.Gen.Depth"
return(tableau)
}
else if(type == "MEAN")
return(GLPriv.variance3V(gen$ind, gen$father, gen$mother, pro = pro))
}
#gen.entropyVar2 = function(gen, pro = 0, typeCorpus = "ECH", bfacteurCorr = F, N = NULL, check = 1, ...)
#{
# #Validation des parametres
# if(length(check) != 1) stop("Invalid 'check' parameter: choices are 0 or 1")
# #stop("Param\350tre 'check' invalide: les choix disponibles sont 0 et 1")
# if(bfacteurCorr == T)
# if(sum(N) == 0)
# stop("Correction factor must have a numerical population size value N")
# #stop("Le facteur de correction doit avoir une valeur num\351rique N taille de la population")
# if(is(gen, "vector"))
# if(length(list(...)) != 2)
# stop("Invalid '...' parameter : 'father' and 'mother' parameter names are obligatory")
# #stop("Param\350tre '...' invalide : indication du nom des param\350tres 'pere' et 'mere' est obligatoire")
# #if(check == 1) {
# retour = gen.detectionErreur(gen = gen, pro = pro, check = c(1, 5))
# if(retour$erreur == T)
# stop(retour$messageErreur)
# gen = retour$gen
# pro = retour$pro
# #}
# tableau = sapply(pro, function(x, gen)
# GLPriv.variance3V(gen$ind, gen$father, gen$mother, pro = x), gen = gen)
# if(typeCorpus == "ECH")
# facteurCorr = length(pro)/(length(pro) - 1)
# else if(typeCorpus == "POP")
# facteurCorr = 1
# if(bfacteurCorr == T)
# facteurCorr = (facteurCorr * (N - length(pro)))/N
# tableau = data.frame(tableau)
# tableau = data.frame(apply(tableau, 2, var) * facteurCorr)
# dimnames(tableau)[[1]] <- "Prof.varEntropie.var"
# dimnames(tableau)[[2]] <- "Prof.varEntropie.var"
# return(tableau)
#}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.