diff --git a/DESCRIPTION b/DESCRIPTION index c90ddec1..f51dc85e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -28,3 +28,6 @@ License: GPL (>= 2) URL: https://cran.r-project.org/package=kinship2 RoxygenNote: 7.2.3 VignetteBuilder: knitr +Suggests: + testthat (>= 3.0.0) +Config/testthat/edition: 3 diff --git a/tests/failure.R b/tests/failure.R deleted file mode 100644 index 0993d5ee..00000000 --- a/tests/failure.R +++ /dev/null @@ -1,26 +0,0 @@ - -require(kinship2) -# -# Here is a case where the levels fail to line up properly -# - -#data(testped2) -data(sample.ped) - -# rearrange the founders to get a nicer plot -df1<- sample.ped[sample.ped$ped==1,] - -ped1 <- with(df1, pedigree(id, father, mother, sex, affected)) - -#plot(ped1) - -df1reord <- df1[c(35:41,1:34),] -ped1reord <- with(df1reord, pedigree(id, father, mother, - sex, affected=affected)) - - -#plot(ped1reord, col=df1reord$avail+1) - - -# Two brothers married two sisters, which is currently "too much" for -# the kindepth routine. diff --git a/tests/failure.Rout.save b/tests/failure.Rout.save deleted file mode 100644 index e520471c..00000000 --- a/tests/failure.Rout.save +++ /dev/null @@ -1,52 +0,0 @@ - -R Under development (unstable) (2022-09-11 r82834) -- "Unsuffered Consequences" -Copyright (C) 2022 The R Foundation for Statistical Computing -Platform: x86_64-pc-linux-gnu (64-bit) - -R is free software and comes with ABSOLUTELY NO WARRANTY. -You are welcome to redistribute it under certain conditions. -Type 'license()' or 'licence()' for distribution details. - - Natural language support but running in an English locale - -R is a collaborative project with many contributors. -Type 'contributors()' for more information and -'citation()' on how to cite R or R packages in publications. - -Type 'demo()' for some demos, 'help()' for on-line help, or -'help.start()' for an HTML browser interface to help. -Type 'q()' to quit R. - -> -> require(kinship2) -Loading required package: kinship2 -Loading required package: Matrix -Loading required package: quadprog -> # -> # Here is a case where the levels fail to line up properly -> # -> -> #data(testped2) -> data(sample.ped) -> -> # rearrange the founders to get a nicer plot -> df1<- sample.ped[sample.ped$ped==1,] -> -> ped1 <- with(df1, pedigree(id, father, mother, sex, affected)) -> -> #plot(ped1) -> -> df1reord <- df1[c(35:41,1:34),] -> ped1reord <- with(df1reord, pedigree(id, father, mother, -+ sex, affected=affected)) -> -> -> #plot(ped1reord, col=df1reord$avail+1) -> -> -> # Two brothers married two sisters, which is currently "too much" for -> # the kindepth routine. -> -> proc.time() - user system elapsed - 2.149 0.145 2.373 diff --git a/tests/makefam.R b/tests/makefam.R deleted file mode 100644 index b3bca1da..00000000 --- a/tests/makefam.R +++ /dev/null @@ -1,11 +0,0 @@ -library(kinship2) -aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) -# -# A pedigree that can cause problems, due to a double marriage -# -id <- 1:20 -mom<- c(0,0,0,2,2,2,0,2,0, 0,2,2,0,2,0,2, 7,7, 11,14) -dad<- c(0,0,0,1,1,1,0,1,0, 0,3,3,0,3,0,3, 8,8, 10,13) - -temp<- makefamid(id, mom, dad) -aeq(temp, pmin(temp,1)) diff --git a/tests/makefam.Rout.save b/tests/makefam.Rout.save deleted file mode 100644 index 59d79063..00000000 --- a/tests/makefam.Rout.save +++ /dev/null @@ -1,37 +0,0 @@ - -R Under development (unstable) (2022-09-11 r82834) -- "Unsuffered Consequences" -Copyright (C) 2022 The R Foundation for Statistical Computing -Platform: x86_64-pc-linux-gnu (64-bit) - -R is free software and comes with ABSOLUTELY NO WARRANTY. -You are welcome to redistribute it under certain conditions. -Type 'license()' or 'licence()' for distribution details. - - Natural language support but running in an English locale - -R is a collaborative project with many contributors. -Type 'contributors()' for more information and -'citation()' on how to cite R or R packages in publications. - -Type 'demo()' for some demos, 'help()' for on-line help, or -'help.start()' for an HTML browser interface to help. -Type 'q()' to quit R. - -> library(kinship2) -Loading required package: Matrix -Loading required package: quadprog -> aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) -> # -> # A pedigree that can cause problems, due to a double marriage -> # -> id <- 1:20 -> mom<- c(0,0,0,2,2,2,0,2,0, 0,2,2,0,2,0,2, 7,7, 11,14) -> dad<- c(0,0,0,1,1,1,0,1,0, 0,3,3,0,3,0,3, 8,8, 10,13) -> -> temp<- makefamid(id, mom, dad) -> aeq(temp, pmin(temp,1)) -[1] TRUE -> -> proc.time() - user system elapsed - 2.162 0.146 2.394 diff --git a/tests/monozygote.R b/tests/monozygote.R deleted file mode 100644 index f0f76676..00000000 --- a/tests/monozygote.R +++ /dev/null @@ -1,58 +0,0 @@ -require(kinship2) - -twindat <- c(1,3,4,2, - 2,0,0,1, - 3,8,7,1, - 4,6,5,2, - 5,0,0,2, - 6,0,0,1, - 7,0,0,2, - 8,0,0,1, - 100,3,4,1, - 101,3,4,2, - 102,3,4,2, - 103,3,4,2, - 104,3,4,2, - 105,3,4,2, - 106,3,4,2, - 107,0,0,1, - 108,0,0,1, - 201,2,1,1, - 202,2,1,1, - 203,2,1,1, - 204,2,1,1, - 205,107,102,1, - 206,108,103,2) -twindat <- matrix(twindat, ncol=4, byrow=T) -dimnames(twindat) <- list(NULL, c('id', 'dadid', 'momid', 'sex')) -twindat <- data.frame(twindat) - -relate=data.frame(id1=c(101,102,101,104,203), id2=c(102,103,103,105,204), - code=c(1,1,1,2,1)) -# -# Renumber everyone as 1,2,....; makes the all.equal checks easier -indx <- sort(unique(unlist(twindat[,1:3]))) -twindat$id <- match(twindat$id, indx) -1 -twindat$dadid <- match(twindat$dadid, indx) -1 -twindat$momid <- match(twindat$momid, indx) -1 -relate$id1 <- match(relate$id1, indx) -1 -relate$id2 <- match(relate$id2, indx) -1 - -# Build the pedigree and kinship -tped <- with(twindat, pedigree(id, dadid, momid, sex, - relation=relate)) -kmat <- kinship(tped) - -truth <- matrix(c(5,6, 0, - 5,4, .25, #parent child - 10,11,.5, # mz twins - 22,12, .25, # aunt, mz with mother - 22, 13, .125, # aunt, dz - 13, 14, .25, # dz twins - 20, 21, .5, # mz twins - 19, 16, 0 , # marry in uncle - 19, 11, .125, # aunt who is a twin - 19, 3, .125), #grandmother - byrow=T, ncol=3) - -all.equal(kmat[truth[,1:2]], truth[,3]) diff --git a/tests/monozygote.Rout.save b/tests/monozygote.Rout.save deleted file mode 100644 index 5349368e..00000000 --- a/tests/monozygote.Rout.save +++ /dev/null @@ -1,85 +0,0 @@ - -R Under development (unstable) (2022-09-11 r82834) -- "Unsuffered Consequences" -Copyright (C) 2022 The R Foundation for Statistical Computing -Platform: x86_64-pc-linux-gnu (64-bit) - -R is free software and comes with ABSOLUTELY NO WARRANTY. -You are welcome to redistribute it under certain conditions. -Type 'license()' or 'licence()' for distribution details. - - Natural language support but running in an English locale - -R is a collaborative project with many contributors. -Type 'contributors()' for more information and -'citation()' on how to cite R or R packages in publications. - -Type 'demo()' for some demos, 'help()' for on-line help, or -'help.start()' for an HTML browser interface to help. -Type 'q()' to quit R. - -> require(kinship2) -Loading required package: kinship2 -Loading required package: Matrix -Loading required package: quadprog -> -> twindat <- c(1,3,4,2, -+ 2,0,0,1, -+ 3,8,7,1, -+ 4,6,5,2, -+ 5,0,0,2, -+ 6,0,0,1, -+ 7,0,0,2, -+ 8,0,0,1, -+ 100,3,4,1, -+ 101,3,4,2, -+ 102,3,4,2, -+ 103,3,4,2, -+ 104,3,4,2, -+ 105,3,4,2, -+ 106,3,4,2, -+ 107,0,0,1, -+ 108,0,0,1, -+ 201,2,1,1, -+ 202,2,1,1, -+ 203,2,1,1, -+ 204,2,1,1, -+ 205,107,102,1, -+ 206,108,103,2) -> twindat <- matrix(twindat, ncol=4, byrow=T) -> dimnames(twindat) <- list(NULL, c('id', 'dadid', 'momid', 'sex')) -> twindat <- data.frame(twindat) -> -> relate=data.frame(id1=c(101,102,101,104,203), id2=c(102,103,103,105,204), -+ code=c(1,1,1,2,1)) -> # -> # Renumber everyone as 1,2,....; makes the all.equal checks easier -> indx <- sort(unique(unlist(twindat[,1:3]))) -> twindat$id <- match(twindat$id, indx) -1 -> twindat$dadid <- match(twindat$dadid, indx) -1 -> twindat$momid <- match(twindat$momid, indx) -1 -> relate$id1 <- match(relate$id1, indx) -1 -> relate$id2 <- match(relate$id2, indx) -1 -> -> # Build the pedigree and kinship -> tped <- with(twindat, pedigree(id, dadid, momid, sex, -+ relation=relate)) -> kmat <- kinship(tped) -> -> truth <- matrix(c(5,6, 0, -+ 5,4, .25, #parent child -+ 10,11,.5, # mz twins -+ 22,12, .25, # aunt, mz with mother -+ 22, 13, .125, # aunt, dz -+ 13, 14, .25, # dz twins -+ 20, 21, .5, # mz twins -+ 19, 16, 0 , # marry in uncle -+ 19, 11, .125, # aunt who is a twin -+ 19, 3, .125), #grandmother -+ byrow=T, ncol=3) -> -> all.equal(kmat[truth[,1:2]], truth[,3]) -[1] TRUE -> -> proc.time() - user system elapsed - 2.224 0.117 2.413 diff --git a/tests/subscript.R b/tests/subscript.R deleted file mode 100644 index 8e859c54..00000000 --- a/tests/subscript.R +++ /dev/null @@ -1,26 +0,0 @@ -# -# Test out subscripting -# -require(kinship2) -data(minnbreast) - -minnped <- with(minnbreast, pedigree(id, fatherid, motherid, sex, - affected=cancer, famid=famid)) -ped8 <- minnped['8'] # a modest sized family - -# Subjects 150, 152, 154, 158 are children, and 143, 162, 149 are -# parents and a child -droplist <- c(150, 152, 154, 158, 143, 162, 149) - -keep1 <- !(ped8$id %in% droplist) #logical -keep2 <- which(keep1) #numeric -keep3 <- as.character(ped8$id[keep1]) #character -keep4 <- factor(keep3) - -test1 <- ped8[keep1] -test2 <- ped8[keep2] -test3 <- ped8[keep3] -test4 <- ped8[keep4] -all.equal(test1, test2) -all.equal(test1, test3) -all.equal(test1, test4) diff --git a/tests/subscript.Rout.save b/tests/subscript.Rout.save deleted file mode 100644 index dfc45b48..00000000 --- a/tests/subscript.Rout.save +++ /dev/null @@ -1,55 +0,0 @@ - -R Under development (unstable) (2022-09-11 r82834) -- "Unsuffered Consequences" -Copyright (C) 2022 The R Foundation for Statistical Computing -Platform: x86_64-pc-linux-gnu (64-bit) - -R is free software and comes with ABSOLUTELY NO WARRANTY. -You are welcome to redistribute it under certain conditions. -Type 'license()' or 'licence()' for distribution details. - - Natural language support but running in an English locale - -R is a collaborative project with many contributors. -Type 'contributors()' for more information and -'citation()' on how to cite R or R packages in publications. - -Type 'demo()' for some demos, 'help()' for on-line help, or -'help.start()' for an HTML browser interface to help. -Type 'q()' to quit R. - -> # -> # Test out subscripting -> # -> require(kinship2) -Loading required package: kinship2 -Loading required package: Matrix -Loading required package: quadprog -> data(minnbreast) -> -> minnped <- with(minnbreast, pedigree(id, fatherid, motherid, sex, -+ affected=cancer, famid=famid)) -> ped8 <- minnped['8'] # a modest sized family -> -> # Subjects 150, 152, 154, 158 are children, and 143, 162, 149 are -> # parents and a child -> droplist <- c(150, 152, 154, 158, 143, 162, 149) -> -> keep1 <- !(ped8$id %in% droplist) #logical -> keep2 <- which(keep1) #numeric -> keep3 <- as.character(ped8$id[keep1]) #character -> keep4 <- factor(keep3) -> -> test1 <- ped8[keep1] -> test2 <- ped8[keep2] -> test3 <- ped8[keep3] -> test4 <- ped8[keep4] -> all.equal(test1, test2) -[1] TRUE -> all.equal(test1, test3) -[1] TRUE -> all.equal(test1, test4) -[1] TRUE -> -> proc.time() - user system elapsed - 2.449 0.160 2.682 diff --git a/tests/test.fixParents.R b/tests/test.fixParents.R deleted file mode 100644 index a09b6ee2..00000000 --- a/tests/test.fixParents.R +++ /dev/null @@ -1,35 +0,0 @@ - -## if all you have is maternal information, fill in for dads -## from user on 2/1/19 -require(kinship2) -materdf <- data.frame(id=1:5, momid=c(0,1,1,2,2), sex=2) - -materdf$dadid <- materdf$momid * 100 -materdf - -peddf <- with(materdf, fixParents(id, dadid, momid, sex)) -peddf -testped <- with(peddf, pedigree(id, dadid, momid, sex)) -as.data.frame(testped) - - -## chars -test1char <- data.frame(id=paste("fam", 101:111, sep=""), - sex=c("male","female")[c(1,2,1,2,1, 1,2, 2,1,2, 1)], - father=c(0,0,"fam101","fam101","fam101", 0,0,"fam106","fam106","fam106", "fam109"), - mother=c(0,0,"fam102","fam102","fam102", 0,0,"fam107","fam107","fam107", "fam112")) -test1newmom <- with(test1char, fixParents(id, father, mother, sex, missid="0")) -newped <- with(test1newmom, pedigree(id, dadid, momid, sex, missid="0")) -as.data.frame(newped) - - -data(sample.ped) -datped2 <- sample.ped[sample.ped$ped %in% 2,] -datped2[datped2$id %in% 203, "sex"] <- 2 -datped2 <- datped2[-which(datped2$id %in% 209),] -## this gets an error -##ped2 <- with(datped2, pedigree(id, father, mother, sex)) -fixped2 <- with(datped2, fixParents(id, father, mother, sex)) -fixped2 -ped2 <- with(fixped2, pedigree(id, dadid, momid, sex)) - diff --git a/tests/test.fixParents.Rout.save b/tests/test.fixParents.Rout.save deleted file mode 100644 index d7f639ca..00000000 --- a/tests/test.fixParents.Rout.save +++ /dev/null @@ -1,111 +0,0 @@ - -R Under development (unstable) (2022-09-11 r82834) -- "Unsuffered Consequences" -Copyright (C) 2022 The R Foundation for Statistical Computing -Platform: x86_64-pc-linux-gnu (64-bit) - -R is free software and comes with ABSOLUTELY NO WARRANTY. -You are welcome to redistribute it under certain conditions. -Type 'license()' or 'licence()' for distribution details. - - Natural language support but running in an English locale - -R is a collaborative project with many contributors. -Type 'contributors()' for more information and -'citation()' on how to cite R or R packages in publications. - -Type 'demo()' for some demos, 'help()' for on-line help, or -'help.start()' for an HTML browser interface to help. -Type 'q()' to quit R. - -> -> ## if all you have is maternal information, fill in for dads -> ## from user on 2/1/19 -> require(kinship2) -Loading required package: kinship2 -Loading required package: Matrix -Loading required package: quadprog -> materdf <- data.frame(id=1:5, momid=c(0,1,1,2,2), sex=2) -> -> materdf$dadid <- materdf$momid * 100 -> materdf - id momid sex dadid -1 1 0 2 0 -2 2 1 2 100 -3 3 1 2 100 -4 4 2 2 200 -5 5 2 2 200 -> -> peddf <- with(materdf, fixParents(id, dadid, momid, sex)) -> peddf - id momid dadid sex -1 1 0 0 2 -2 2 1 100 2 -3 3 1 100 2 -4 4 2 200 2 -5 5 2 200 2 -6 100 0 0 1 -7 200 0 0 1 -> testped <- with(peddf, pedigree(id, dadid, momid, sex)) -> as.data.frame(testped) - id dadid momid sex -1 1 0 0 female -2 2 100 1 female -3 3 100 1 female -4 4 200 2 female -5 5 200 2 female -6 100 0 0 male -7 200 0 0 male -> -> -> ## chars -> test1char <- data.frame(id=paste("fam", 101:111, sep=""), -+ sex=c("male","female")[c(1,2,1,2,1, 1,2, 2,1,2, 1)], -+ father=c(0,0,"fam101","fam101","fam101", 0,0,"fam106","fam106","fam106", "fam109"), -+ mother=c(0,0,"fam102","fam102","fam102", 0,0,"fam107","fam107","fam107", "fam112")) -> test1newmom <- with(test1char, fixParents(id, father, mother, sex, missid="0")) -> newped <- with(test1newmom, pedigree(id, dadid, momid, sex, missid="0")) -> as.data.frame(newped) - id dadid momid sex -1 fam101 0 0 male -2 fam102 0 0 female -3 fam103 fam101 fam102 male -4 fam104 fam101 fam102 female -5 fam105 fam101 fam102 male -6 fam106 0 0 male -7 fam107 0 0 female -8 fam108 fam106 fam107 female -9 fam109 fam106 fam107 male -10 fam110 fam106 fam107 female -11 fam111 fam109 fam112 male -12 fam112 0 0 female -> -> -> data(sample.ped) -> datped2 <- sample.ped[sample.ped$ped %in% 2,] -> datped2[datped2$id %in% 203, "sex"] <- 2 -> datped2 <- datped2[-which(datped2$id %in% 209),] -> ## this gets an error -> ##ped2 <- with(datped2, pedigree(id, father, mother, sex)) -> fixped2 <- with(datped2, fixParents(id, father, mother, sex)) -> fixped2 - id momid dadid sex -1 201 0 0 1 -2 202 0 0 2 -3 203 0 0 1 -4 204 202 201 2 -5 205 202 201 1 -6 206 202 201 2 -7 207 202 201 2 -8 208 202 201 2 -9 210 204 203 1 -10 211 204 203 1 -11 212 208 209 2 -12 213 208 209 1 -13 214 208 209 1 -14 209 0 0 1 -> ped2 <- with(fixped2, pedigree(id, dadid, momid, sex)) -> -> -> proc.time() - user system elapsed - 2.218 0.148 2.513 diff --git a/tests/test.kinX.R b/tests/test.kinX.R deleted file mode 100644 index a867615c..00000000 --- a/tests/test.kinX.R +++ /dev/null @@ -1,68 +0,0 @@ - -## test pedigree from bioinformatics manuscript -## try x-chrom kinship -## also has inbreeding and twins, for quick check -require(kinship2) -ped2mat <- matrix(c(1,1,0,0,1, - 1,2,0,0,2, - 1,3,1,2,1, - 1,4,1,2,2, - 1,5,0,0,2, - 1,6,0,0,1, - 1,7,3,5,2, - 1,8,6,4,1, - 1,9,6,4,1, - 1,10,8,7,2),ncol=5,byrow=TRUE) - -ped2df <- as.data.frame(ped2mat) -names(ped2df) <- c("fam", "id", "dad", "mom", "sex") - ## 1 2 3 4 5 6 7 8 9 10,11,12,13,14,15,16 -ped2df$disease= c(NA,NA,1,0,0,0,0,1,1,1) -ped2df$smoker= c(0,NA,0,0,1,1,1,0,0,0) -ped2df$availstatus=c(0,0, 1,1,0,1,1,1,1,1) -ped2df$vitalstatus=c(1,1, 1,0,1,0,0,0,0,0) - -ped2 <- with(ped2df, pedigree(id, dad, mom, sex, status=vitalstatus, - affected=cbind(disease,smoker, availstatus), relation=matrix(c(8,9,1),ncol=3))) - -## regular kinship matrix -kinship(ped2) - -kinship(ped2, chr="X") - -ped2$sex[9] <- "unknown" - -## regular again, should be same as above -kinship(ped2) - -## now with unknown sex, gets NAs -kinship(ped2, chrtype="X") - -ped2$sex[9]="unknown" -kinship(ped2, chrtype="x") - - -# all descendants of sex=unknown to be NAs as well -ped2$sex[8]="unknown" -kinship(ped2, chr="X") - - -## testing kinship2 on pedigreeList when only one subject in a family -peddf <- rbind(ped2df, c(2,1,0,0,1,1,0,1,0)) - -peds <- with(peddf, pedigree(id, dad, mom, sex, status=vitalstatus,fam=fam, - affected=cbind(disease,smoker, availstatus))) - -kinfam <- kinship(peds) - -kinfam - -## now add two more for ped2, and check again -peddf <- rbind(peddf, c(2,2,0,0,2,1,0,1,0),c(2,3,1,2,1,1,0,1,0)) - -peds <- with(peddf, pedigree(id, dad, mom, sex, status=vitalstatus,fam=fam, - affected=cbind(disease,smoker, availstatus))) - -kin2fam <- kinship(peds) - -kin2fam diff --git a/tests/test.kinX.Rout.save b/tests/test.kinX.Rout.save deleted file mode 100644 index 563ad3d7..00000000 --- a/tests/test.kinX.Rout.save +++ /dev/null @@ -1,204 +0,0 @@ - -R Under development (unstable) (2022-09-11 r82834) -- "Unsuffered Consequences" -Copyright (C) 2022 The R Foundation for Statistical Computing -Platform: x86_64-pc-linux-gnu (64-bit) - -R is free software and comes with ABSOLUTELY NO WARRANTY. -You are welcome to redistribute it under certain conditions. -Type 'license()' or 'licence()' for distribution details. - - Natural language support but running in an English locale - -R is a collaborative project with many contributors. -Type 'contributors()' for more information and -'citation()' on how to cite R or R packages in publications. - -Type 'demo()' for some demos, 'help()' for on-line help, or -'help.start()' for an HTML browser interface to help. -Type 'q()' to quit R. - -> -> ## test pedigree from bioinformatics manuscript -> ## try x-chrom kinship -> ## also has inbreeding and twins, for quick check -> require(kinship2) -Loading required package: kinship2 -Loading required package: Matrix -Loading required package: quadprog -> ped2mat <- matrix(c(1,1,0,0,1, -+ 1,2,0,0,2, -+ 1,3,1,2,1, -+ 1,4,1,2,2, -+ 1,5,0,0,2, -+ 1,6,0,0,1, -+ 1,7,3,5,2, -+ 1,8,6,4,1, -+ 1,9,6,4,1, -+ 1,10,8,7,2),ncol=5,byrow=TRUE) -> -> ped2df <- as.data.frame(ped2mat) -> names(ped2df) <- c("fam", "id", "dad", "mom", "sex") -> ## 1 2 3 4 5 6 7 8 9 10,11,12,13,14,15,16 -> ped2df$disease= c(NA,NA,1,0,0,0,0,1,1,1) -> ped2df$smoker= c(0,NA,0,0,1,1,1,0,0,0) -> ped2df$availstatus=c(0,0, 1,1,0,1,1,1,1,1) -> ped2df$vitalstatus=c(1,1, 1,0,1,0,0,0,0,0) -> -> ped2 <- with(ped2df, pedigree(id, dad, mom, sex, status=vitalstatus, -+ affected=cbind(disease,smoker, availstatus), relation=matrix(c(8,9,1),ncol=3))) -> -> ## regular kinship matrix -> kinship(ped2) - 1 2 3 4 5 6 7 8 9 10 -1 0.500 0.000 0.2500 0.2500 0.000 0.000 0.12500 0.12500 0.12500 0.12500 -2 0.000 0.500 0.2500 0.2500 0.000 0.000 0.12500 0.12500 0.12500 0.12500 -3 0.250 0.250 0.5000 0.2500 0.000 0.000 0.25000 0.12500 0.12500 0.18750 -4 0.250 0.250 0.2500 0.5000 0.000 0.000 0.12500 0.25000 0.25000 0.18750 -5 0.000 0.000 0.0000 0.0000 0.500 0.000 0.25000 0.00000 0.00000 0.12500 -6 0.000 0.000 0.0000 0.0000 0.000 0.500 0.00000 0.25000 0.25000 0.12500 -7 0.125 0.125 0.2500 0.1250 0.250 0.000 0.50000 0.06250 0.06250 0.28125 -8 0.125 0.125 0.1250 0.2500 0.000 0.250 0.06250 0.50000 0.50000 0.28125 -9 0.125 0.125 0.1250 0.2500 0.000 0.250 0.06250 0.50000 0.50000 0.28125 -10 0.125 0.125 0.1875 0.1875 0.125 0.125 0.28125 0.28125 0.28125 0.53125 -> -> kinship(ped2, chr="X") - 1 2 3 4 5 6 7 8 9 10 -1 1.00 0.00 0.000 0.5000 0.000 0 0.0000 0.5000 0.5000 0.2500 -2 0.00 0.50 0.500 0.2500 0.000 0 0.2500 0.2500 0.2500 0.2500 -3 0.00 0.50 1.000 0.2500 0.000 0 0.5000 0.2500 0.2500 0.3750 -4 0.50 0.25 0.250 0.5000 0.000 0 0.1250 0.5000 0.5000 0.3125 -5 0.00 0.00 0.000 0.0000 0.500 0 0.2500 0.0000 0.0000 0.1250 -6 0.00 0.00 0.000 0.0000 0.000 1 0.0000 0.0000 0.0000 0.0000 -7 0.00 0.25 0.500 0.1250 0.250 0 0.5000 0.1250 0.1250 0.3125 -8 0.50 0.25 0.250 0.5000 0.000 0 0.1250 1.0000 1.0000 0.5625 -9 0.50 0.25 0.250 0.5000 0.000 0 0.1250 1.0000 1.0000 0.5625 -10 0.25 0.25 0.375 0.3125 0.125 0 0.3125 0.5625 0.5625 0.5625 -> -> ped2$sex[9] <- "unknown" -> -> ## regular again, should be same as above -> kinship(ped2) - 1 2 3 4 5 6 7 8 9 10 -1 0.500 0.000 0.2500 0.2500 0.000 0.000 0.12500 0.12500 0.12500 0.12500 -2 0.000 0.500 0.2500 0.2500 0.000 0.000 0.12500 0.12500 0.12500 0.12500 -3 0.250 0.250 0.5000 0.2500 0.000 0.000 0.25000 0.12500 0.12500 0.18750 -4 0.250 0.250 0.2500 0.5000 0.000 0.000 0.12500 0.25000 0.25000 0.18750 -5 0.000 0.000 0.0000 0.0000 0.500 0.000 0.25000 0.00000 0.00000 0.12500 -6 0.000 0.000 0.0000 0.0000 0.000 0.500 0.00000 0.25000 0.25000 0.12500 -7 0.125 0.125 0.2500 0.1250 0.250 0.000 0.50000 0.06250 0.06250 0.28125 -8 0.125 0.125 0.1250 0.2500 0.000 0.250 0.06250 0.50000 0.50000 0.28125 -9 0.125 0.125 0.1250 0.2500 0.000 0.250 0.06250 0.50000 0.50000 0.28125 -10 0.125 0.125 0.1875 0.1875 0.125 0.125 0.28125 0.28125 0.28125 0.53125 -> -> ## now with unknown sex, gets NAs -> kinship(ped2, chrtype="X") - 1 2 3 4 5 6 7 8 9 10 -1 1.00 0.00 0.000 0.5000 0.000 0 0.0000 0.5000 NA 0.2500 -2 0.00 0.50 0.500 0.2500 0.000 0 0.2500 0.2500 NA 0.2500 -3 0.00 0.50 1.000 0.2500 0.000 0 0.5000 0.2500 NA 0.3750 -4 0.50 0.25 0.250 0.5000 0.000 0 0.1250 0.5000 NA 0.3125 -5 0.00 0.00 0.000 0.0000 0.500 0 0.2500 0.0000 NA 0.1250 -6 0.00 0.00 0.000 0.0000 0.000 1 0.0000 0.0000 NA 0.0000 -7 0.00 0.25 0.500 0.1250 0.250 0 0.5000 0.1250 NA 0.3125 -8 0.50 0.25 0.250 0.5000 0.000 0 0.1250 1.0000 1 0.5625 -9 NA NA NA NA NA NA NA NA NA NA -10 0.25 0.25 0.375 0.3125 0.125 0 0.3125 0.5625 NA 0.5625 -> -> ped2$sex[9]="unknown" -> kinship(ped2, chrtype="x") - 1 2 3 4 5 6 7 8 9 10 -1 1.00 0.00 0.000 0.5000 0.000 0 0.0000 0.5000 NA 0.2500 -2 0.00 0.50 0.500 0.2500 0.000 0 0.2500 0.2500 NA 0.2500 -3 0.00 0.50 1.000 0.2500 0.000 0 0.5000 0.2500 NA 0.3750 -4 0.50 0.25 0.250 0.5000 0.000 0 0.1250 0.5000 NA 0.3125 -5 0.00 0.00 0.000 0.0000 0.500 0 0.2500 0.0000 NA 0.1250 -6 0.00 0.00 0.000 0.0000 0.000 1 0.0000 0.0000 NA 0.0000 -7 0.00 0.25 0.500 0.1250 0.250 0 0.5000 0.1250 NA 0.3125 -8 0.50 0.25 0.250 0.5000 0.000 0 0.1250 1.0000 1 0.5625 -9 NA NA NA NA NA NA NA NA NA NA -10 0.25 0.25 0.375 0.3125 0.125 0 0.3125 0.5625 NA 0.5625 -> -> -> # all descendants of sex=unknown to be NAs as well -> ped2$sex[8]="unknown" -> kinship(ped2, chr="X") - 1 2 3 4 5 6 7 8 9 10 -1 1.0 0.00 0.00 0.500 0.00 0 0.000 NA NA NA -2 0.0 0.50 0.50 0.250 0.00 0 0.250 NA NA NA -3 0.0 0.50 1.00 0.250 0.00 0 0.500 NA NA NA -4 0.5 0.25 0.25 0.500 0.00 0 0.125 NA NA NA -5 0.0 0.00 0.00 0.000 0.50 0 0.250 NA NA NA -6 0.0 0.00 0.00 0.000 0.00 1 0.000 NA NA NA -7 0.0 0.25 0.50 0.125 0.25 0 0.500 NA NA NA -8 NA NA NA NA NA NA NA NA NA NA -9 NA NA NA NA NA NA NA NA NA NA -10 NA NA NA NA NA NA NA NA NA NA -> -> -> ## testing kinship2 on pedigreeList when only one subject in a family -> peddf <- rbind(ped2df, c(2,1,0,0,1,1,0,1,0)) -> -> peds <- with(peddf, pedigree(id, dad, mom, sex, status=vitalstatus,fam=fam, -+ affected=cbind(disease,smoker, availstatus))) -> -> kinfam <- kinship(peds) -> -> kinfam -11 x 11 sparse Matrix of class "dsCMatrix" - [[ suppressing 11 column names ‘1/1’, ‘1/2’, ‘1/3’ ... ]] - -1/1 0.500 . 0.2500 0.2500 . . 0.12500 0.12500 0.12500 0.12500 . -1/2 . 0.500 0.2500 0.2500 . . 0.12500 0.12500 0.12500 0.12500 . -1/3 0.250 0.250 0.5000 0.2500 . . 0.25000 0.12500 0.12500 0.18750 . -1/4 0.250 0.250 0.2500 0.5000 . . 0.12500 0.25000 0.25000 0.18750 . -1/5 . . . . 0.500 . 0.25000 . . 0.12500 . -1/6 . . . . . 0.500 . 0.25000 0.25000 0.12500 . -1/7 0.125 0.125 0.2500 0.1250 0.250 . 0.50000 0.06250 0.06250 0.28125 . -1/8 0.125 0.125 0.1250 0.2500 . 0.250 0.06250 0.50000 0.25000 0.28125 . -1/9 0.125 0.125 0.1250 0.2500 . 0.250 0.06250 0.25000 0.50000 0.15625 . -1/10 0.125 0.125 0.1875 0.1875 0.125 0.125 0.28125 0.28125 0.15625 0.53125 . -2/1 . . . . . . . . . . 0.5 -> -> ## now add two more for ped2, and check again -> peddf <- rbind(peddf, c(2,2,0,0,2,1,0,1,0),c(2,3,1,2,1,1,0,1,0)) -> -> peds <- with(peddf, pedigree(id, dad, mom, sex, status=vitalstatus,fam=fam, -+ affected=cbind(disease,smoker, availstatus))) -> -> kin2fam <- kinship(peds) -> -> kin2fam -13 x 13 sparse Matrix of class "dsCMatrix" - [[ suppressing 13 column names ‘1/1’, ‘1/2’, ‘1/3’ ... ]] - -1/1 0.500 . 0.2500 0.2500 . . 0.12500 0.12500 0.12500 0.12500 . -1/2 . 0.500 0.2500 0.2500 . . 0.12500 0.12500 0.12500 0.12500 . -1/3 0.250 0.250 0.5000 0.2500 . . 0.25000 0.12500 0.12500 0.18750 . -1/4 0.250 0.250 0.2500 0.5000 . . 0.12500 0.25000 0.25000 0.18750 . -1/5 . . . . 0.500 . 0.25000 . . 0.12500 . -1/6 . . . . . 0.500 . 0.25000 0.25000 0.12500 . -1/7 0.125 0.125 0.2500 0.1250 0.250 . 0.50000 0.06250 0.06250 0.28125 . -1/8 0.125 0.125 0.1250 0.2500 . 0.250 0.06250 0.50000 0.25000 0.28125 . -1/9 0.125 0.125 0.1250 0.2500 . 0.250 0.06250 0.25000 0.50000 0.15625 . -1/10 0.125 0.125 0.1875 0.1875 0.125 0.125 0.28125 0.28125 0.15625 0.53125 . -2/1 . . . . . . . . . . 0.50 -2/2 . . . . . . . . . . . -2/3 . . . . . . . . . . 0.25 - -1/1 . . -1/2 . . -1/3 . . -1/4 . . -1/5 . . -1/6 . . -1/7 . . -1/8 . . -1/9 . . -1/10 . . -2/1 . 0.25 -2/2 0.50 0.25 -2/3 0.25 0.50 -> -> proc.time() - user system elapsed - 2.340 0.158 2.643 diff --git a/tests/test.pedigree.shrink.R b/tests/test.pedigree.shrink.R deleted file mode 100644 index becd5e3f..00000000 --- a/tests/test.pedigree.shrink.R +++ /dev/null @@ -1,99 +0,0 @@ - -## -## example data and test steps from pedigree.shrink -## Jason Sinnwell -## - -require(kinship2) - - -data(minnbreast) -pedMN <- with(minnbreast, pedigree(id, fatherid, motherid, sex,famid=famid, - affected=cbind(cancer, bcpc, proband))) - - - -## this pedigree as one person with cancer. The pedigree is not informative -## if they are the only available, so pedigree.shrink trims all. -## This caused an error in pedigree.shrink before kinship2. v1.2.8. Now fixed -mn2 <- pedMN[2] -#plot(mn2) - -## breaks in pedigree.trim -shrink.mn2 <- pedigree.shrink(mn2, - avail=ifelse(is.na(mn2$affected[,1]), 0, mn2$affected[,1])) -shrink.mn2 - -mnf8 <- pedMN['8'] -#plot(mnf8) -shrink.mnf8 <- pedigree.shrink(mnf8, - avail=ifelse(is.na(mnf8$affected[,1]), 0, mnf8$affected[,1])) - -shrink.mnf8 - - -## use sample.ped from the package -data(sample.ped) - -pedAll <- pedigree(sample.ped$id, sample.ped$father, sample.ped$mother, - sample.ped$sex, - affected=cbind(sample.ped$affected, sample.ped$avail), - famid=sample.ped$ped) - - -ped1 <- pedAll['1'] - -ped2 <- pedAll['2'] - -ped2$sex[c(13,12)] <- c("unknown", "terminated") - - -## set 2nd col of affected to NA -ped2$affected[c(7,9),2] <- NA - - -set.seed(10) -shrink1.avail.B32 <- pedigree.shrink(ped=ped1, avail=ped1$affected[,2], maxBits=32) - -set.seed(10) -shrink1.avail.B25 <- pedigree.shrink(ped=ped1, avail=ped1$affected[,2], maxBits=25) - -shrink1.avail.B32$idTrimmed -## 101 102 107 108 111 121 122 123 131 132 134 139 -shrink1.avail.B25$idTrimmed -## 101 102 107 108 111 121 122 123 131 132 134 139 125 126 - -print(shrink1.avail.B32) -print(shrink1.avail.B25) - - -#Pedigree Size: -# N.subj Bits -#Original 41 49 -#Only Informative 29 31 -#Trimmed 26 25 - -# Unavailable subjects trimmed: -# 101 102 107 108 111 121 122 123 131 132 134 139 -# -# Informative subjects trimmed: -# 125 126 - -ped1df <- as.data.frame(ped1) - -ped1df$idchar <- gsub("^1","A-", as.character(ped1df$id)) -ped1df$dadidchar <- gsub("^1","A-", as.character(ped1df$dadid)) -ped1df$momidchar <- gsub("^1","A-", as.character(ped1df$momid)) -#ped1df$dadidchar <- ifelse(ped1df$dadidchar=="0", NA, ped1df$dadidchar) -#ped1df$momidchar <- ifelse(ped1df$momidchar=="0", NA, ped1df$momidchar) -ped1char <- with(ped1df, pedigree(idchar, dadidchar, momidchar, sex, affected,missid=c("0"))) - -set.seed(100) -shrink1.p1char.B32 <- pedigree.shrink(ped=ped1char, avail=ped1char$affected[,2], maxBits=32) -shrink1.p1char.B32$idTrimmed -shrink1.avail.B32$idTrimmed - -set.seed(100) -shrink1.p1char.B25 <- pedigree.shrink(ped=ped1char, avail=ped1char$affected[,2], maxBits=25) -shrink1.p1char.B25$idTrimmed -shrink1.avail.B25$idTrimmed diff --git a/tests/test.pedigree.shrink.Rout.save b/tests/test.pedigree.shrink.Rout.save deleted file mode 100644 index 9331368e..00000000 --- a/tests/test.pedigree.shrink.Rout.save +++ /dev/null @@ -1,170 +0,0 @@ - -R Under development (unstable) (2022-09-11 r82834) -- "Unsuffered Consequences" -Copyright (C) 2022 The R Foundation for Statistical Computing -Platform: x86_64-pc-linux-gnu (64-bit) - -R is free software and comes with ABSOLUTELY NO WARRANTY. -You are welcome to redistribute it under certain conditions. -Type 'license()' or 'licence()' for distribution details. - - Natural language support but running in an English locale - -R is a collaborative project with many contributors. -Type 'contributors()' for more information and -'citation()' on how to cite R or R packages in publications. - -Type 'demo()' for some demos, 'help()' for on-line help, or -'help.start()' for an HTML browser interface to help. -Type 'q()' to quit R. - -> -> ## -> ## example data and test steps from pedigree.shrink -> ## Jason Sinnwell -> ## -> -> require(kinship2) -Loading required package: kinship2 -Loading required package: Matrix -Loading required package: quadprog -> -> -> data(minnbreast) -> pedMN <- with(minnbreast, pedigree(id, fatherid, motherid, sex,famid=famid, -+ affected=cbind(cancer, bcpc, proband))) -> -> -> -> ## this pedigree as one person with cancer. The pedigree is not informative -> ## if they are the only available, so pedigree.shrink trims all. -> ## This caused an error in pedigree.shrink before kinship2. v1.2.8. Now fixed -> mn2 <- pedMN[2] -> #plot(mn2) -> -> ## breaks in pedigree.trim -> shrink.mn2 <- pedigree.shrink(mn2, -+ avail=ifelse(is.na(mn2$affected[,1]), 0, mn2$affected[,1])) -> shrink.mn2 -Pedigree Size: - N.subj Bits -Original 38 19 -Only Informative 0 0 -Trimmed 0 0 - - Unavailable subjects trimmed: - 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 26050 26051 -> -> mnf8 <- pedMN['8'] -> #plot(mnf8) -> shrink.mnf8 <- pedigree.shrink(mnf8, -+ avail=ifelse(is.na(mnf8$affected[,1]), 0, mnf8$affected[,1])) -> -> shrink.mnf8 -Pedigree Size: - N.subj Bits -Original 40 26 -Only Informative 8 4 -Trimmed 8 4 - - Unavailable subjects trimmed: - 137 138 139 140 144 145 146 147 148 150 151 152 153 154 155 156 157 158 159 160 163 164 165 166 167 168 169 170 171 172 173 174 -> -> -> ## use sample.ped from the package -> data(sample.ped) -> -> pedAll <- pedigree(sample.ped$id, sample.ped$father, sample.ped$mother, -+ sample.ped$sex, -+ affected=cbind(sample.ped$affected, sample.ped$avail), -+ famid=sample.ped$ped) -> -> -> ped1 <- pedAll['1'] -> -> ped2 <- pedAll['2'] -> -> ped2$sex[c(13,12)] <- c("unknown", "terminated") -> -> -> ## set 2nd col of affected to NA -> ped2$affected[c(7,9),2] <- NA -> -> -> set.seed(10) -> shrink1.avail.B32 <- pedigree.shrink(ped=ped1, avail=ped1$affected[,2], maxBits=32) -> -> set.seed(10) -> shrink1.avail.B25 <- pedigree.shrink(ped=ped1, avail=ped1$affected[,2], maxBits=25) -> -> shrink1.avail.B32$idTrimmed - [1] 101 102 107 108 111 113 121 122 123 131 132 134 139 -> ## 101 102 107 108 111 121 122 123 131 132 134 139 -> shrink1.avail.B25$idTrimmed - id -101 102 107 108 111 113 121 122 123 131 132 134 139 140 141 -> ## 101 102 107 108 111 121 122 123 131 132 134 139 125 126 -> -> print(shrink1.avail.B32) -Pedigree Size: - N.subj Bits -Original 41 46 -Only Informative 28 29 -Trimmed 28 29 - - Unavailable subjects trimmed: - 101 102 107 108 111 113 121 122 123 131 132 134 139 -> print(shrink1.avail.B25) -Pedigree Size: - N.subj Bits -Original 41 46 -Only Informative 28 29 -Trimmed 22 23 - - Unavailable subjects trimmed: - 101 102 107 108 111 113 121 122 123 131 132 134 139 - - Informative subjects trimmed: - 140 141 -> -> -> #Pedigree Size: -> # N.subj Bits -> #Original 41 49 -> #Only Informative 29 31 -> #Trimmed 26 25 -> -> # Unavailable subjects trimmed: -> # 101 102 107 108 111 121 122 123 131 132 134 139 -> # -> # Informative subjects trimmed: -> # 125 126 -> -> ped1df <- as.data.frame(ped1) -> -> ped1df$idchar <- gsub("^1","A-", as.character(ped1df$id)) -> ped1df$dadidchar <- gsub("^1","A-", as.character(ped1df$dadid)) -> ped1df$momidchar <- gsub("^1","A-", as.character(ped1df$momid)) -> #ped1df$dadidchar <- ifelse(ped1df$dadidchar=="0", NA, ped1df$dadidchar) -> #ped1df$momidchar <- ifelse(ped1df$momidchar=="0", NA, ped1df$momidchar) -> ped1char <- with(ped1df, pedigree(idchar, dadidchar, momidchar, sex, affected,missid=c("0"))) -> -> set.seed(100) -> shrink1.p1char.B32 <- pedigree.shrink(ped=ped1char, avail=ped1char$affected[,2], maxBits=32) -> shrink1.p1char.B32$idTrimmed - [1] "A-01" "A-02" "A-07" "A-08" "A-11" "A-13" "A-21" "A-22" "A-23" "A-31" -[11] "A-32" "A-34" "A-39" -> shrink1.avail.B32$idTrimmed - [1] 101 102 107 108 111 113 121 122 123 131 132 134 139 -> -> set.seed(100) -> shrink1.p1char.B25 <- pedigree.shrink(ped=ped1char, avail=ped1char$affected[,2], maxBits=25) -> shrink1.p1char.B25$idTrimmed - [1] "A-01" "A-02" "A-07" "A-08" "A-11" "A-13" "A-21" "A-22" "A-23" "A-31" -[11] "A-32" "A-34" "A-39" "A-33" "A-41" -> shrink1.avail.B25$idTrimmed - id -101 102 107 108 111 113 121 122 123 131 132 134 139 140 141 -> -> proc.time() - user system elapsed - 2.836 0.139 3.054 diff --git a/tests/test.pedigree.unrelated.R b/tests/test.pedigree.unrelated.R deleted file mode 100644 index 6bb24d30..00000000 --- a/tests/test.pedigree.unrelated.R +++ /dev/null @@ -1,45 +0,0 @@ -####################################### -## Name: test.pedigree.unrelated.r -## Purpose: Test Suite for pedigree.unrelated -## Created: 3/29/2011 -## Last Updated: 7/13/2011 -## Author: Jason Sinnwell, MS -######################################## - -## examples from help file, available with -## > example(pedigree.unrelated) - -require(kinship2) -#library(kinship2, lib.loc="~/Rdir/library") -#citation("kinship2") - -data(sample.ped) - - -pedAll <- pedigree(sample.ped$id, sample.ped$father, sample.ped$mother, - sample.ped$sex, famid=sample.ped$ped, - affected=cbind(sample.ped$affected, sample.ped$avail)) - -ped1 <- pedAll['1'] -ped2 <- pedAll['2'] - -## to see plot: -## plot.pedigree(ped1, align=FALSE) -set.seed(10) -id1 <- pedigree.unrelated(ped1, avail=ped1$affected[,2]) - -## some possible vectors -id1 -# "109" "113" "133" -# "109" "110" "130" -# "109" "118" "141" - -set.seed(10) -id2 <- pedigree.unrelated(ped2, avail=ped2$affected[,2]) - -## some possible vectors -id2 -##[1] "203" "206" -##[1] "203" "213" -##[1] "203" "204" - diff --git a/tests/test.pedigree.unrelated.Rout.save b/tests/test.pedigree.unrelated.Rout.save deleted file mode 100644 index 9872e77a..00000000 --- a/tests/test.pedigree.unrelated.Rout.save +++ /dev/null @@ -1,73 +0,0 @@ - -R Under development (unstable) (2022-09-11 r82834) -- "Unsuffered Consequences" -Copyright (C) 2022 The R Foundation for Statistical Computing -Platform: x86_64-pc-linux-gnu (64-bit) - -R is free software and comes with ABSOLUTELY NO WARRANTY. -You are welcome to redistribute it under certain conditions. -Type 'license()' or 'licence()' for distribution details. - - Natural language support but running in an English locale - -R is a collaborative project with many contributors. -Type 'contributors()' for more information and -'citation()' on how to cite R or R packages in publications. - -Type 'demo()' for some demos, 'help()' for on-line help, or -'help.start()' for an HTML browser interface to help. -Type 'q()' to quit R. - -> ####################################### -> ## Name: test.pedigree.unrelated.r -> ## Purpose: Test Suite for pedigree.unrelated -> ## Created: 3/29/2011 -> ## Last Updated: 7/13/2011 -> ## Author: Jason Sinnwell, MS -> ######################################## -> -> ## examples from help file, available with -> ## > example(pedigree.unrelated) -> -> require(kinship2) -Loading required package: kinship2 -Loading required package: Matrix -Loading required package: quadprog -> #library(kinship2, lib.loc="~/Rdir/library") -> #citation("kinship2") -> -> data(sample.ped) -> -> -> pedAll <- pedigree(sample.ped$id, sample.ped$father, sample.ped$mother, -+ sample.ped$sex, famid=sample.ped$ped, -+ affected=cbind(sample.ped$affected, sample.ped$avail)) -> -> ped1 <- pedAll['1'] -> ped2 <- pedAll['2'] -> -> ## to see plot: -> ## plot.pedigree(ped1, align=FALSE) -> set.seed(10) -> id1 <- pedigree.unrelated(ped1, avail=ped1$affected[,2]) -> -> ## some possible vectors -> id1 -[1] "109" "113" "133" "141" -> # "109" "113" "133" -> # "109" "110" "130" -> # "109" "118" "141" -> -> set.seed(10) -> id2 <- pedigree.unrelated(ped2, avail=ped2$affected[,2]) -> -> ## some possible vectors -> id2 -[1] "203" "206" -> ##[1] "203" "206" -> ##[1] "203" "213" -> ##[1] "203" "204" -> -> -> proc.time() - user system elapsed - 2.258 0.143 2.604 diff --git a/tests/testthat.R b/tests/testthat.R new file mode 100644 index 00000000..c1415abf --- /dev/null +++ b/tests/testthat.R @@ -0,0 +1,12 @@ +# This file is part of the standard setup for testthat. +# It is recommended that you do not modify it. +# +# Where should you do additional test configuration? +# Learn more about the roles of various files in: +# * https://r-pkgs.org/tests.html +# * https://testthat.r-lib.org/reference/test_package.html#special-files + +library(testthat) +library(kinship2) + +test_check("kinship2") diff --git a/tests/testthat/_snaps/align.md b/tests/testthat/_snaps/align.md new file mode 100644 index 00000000..cb6b4d31 --- /dev/null +++ b/tests/testthat/_snaps/align.md @@ -0,0 +1,82 @@ +# align.pedigree works + + Code + align.pedigree(ped) + Output + $n + [1] 8 19 22 8 + + $nid + [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] + [1,] 5 6 7 8 35 36 42 43 0 + [2,] 1 2 15 17 16 18 19 20 3 + [3,] 9 10 29 30 31 32 33 34 10 + [4,] 21 22 23 24 25 26 27 28 0 + [,10] [,11] [,12] [,13] [,14] [,15] [,16] + [1,] 0 0 0 0 0 0 0 + [2,] 4 37 38 44 45 46 47 + [3,] 11 12 18 14 15 39 40 + [4,] 0 0 0 0 0 0 0 + [,17] [,18] [,19] [,20] [,21] [,22] + [1,] 0 0 0 0 0 0 + [2,] 48 50 49 0 0 0 + [3,] 41 51 52 53 54 55 + [4,] 0 0 0 0 0 0 + + $pos + [,1] [,2] [,3] [,4] [,5] + [1,] 3.750000e+00 4.75 6.50 7.50 11.75536 + [2,] -4.541957e-13 1.00 2.00 3.00 4.00000 + [3,] 1.000000e-02 1.01 2.01 3.01 4.01000 + [4,] 1.939898e-16 1.00 2.00 3.00 10.01000 + [,6] [,7] [,8] [,9] [,10] [,11] + [1,] 12.75536 17.71 18.71 0.00000 0.00000 0.00 + [2,] 5.00000 6.00 7.00 10.50072 11.50072 13.01 + [3,] 5.01000 6.01 7.01 8.01000 9.01000 10.01 + [4,] 11.01000 12.01 13.01 0.00000 0.00000 0.00 + [,12] [,13] [,14] [,15] [,16] [,17] [,18] + [1,] 0.00 0.00 0.00 0.00 0.00 0.00 0.00 + [2,] 14.01 15.01 16.01 17.01 18.01 19.01 20.01 + [3,] 11.01 12.01 13.01 14.01 15.01 16.01 17.01 + [4,] 0.00 0.00 0.00 0.00 0.00 0.00 0.00 + [,19] [,20] [,21] [,22] + [1,] 0.00 0.00 0.00 0.00 + [2,] 21.01 0.00 0.00 0.00 + [3,] 18.01 19.01 20.01 21.01 + [4,] 0.00 0.00 0.00 0.00 + + $fam + [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] + [1,] 0 0 0 0 0 0 0 0 0 + [2,] 0 0 1 0 1 1 1 3 5 + [3,] 1 0 4 7 7 7 7 7 9 + [4,] 1 1 1 1 11 11 13 13 0 + [,10] [,11] [,12] [,13] [,14] [,15] [,16] + [1,] 0 0 0 0 0 0 0 + [2,] 0 0 5 0 7 7 7 + [3,] 9 9 0 9 0 11 11 + [4,] 0 0 0 0 0 0 0 + [,17] [,18] [,19] [,20] [,21] [,22] + [1,] 0 0 0 0 0 0 + [2,] 7 0 7 0 0 0 + [3,] 11 13 13 18 18 18 + [4,] 0 0 0 0 0 0 + + $spouse + [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] + [1,] 1 0 1 0 1 0 1 0 0 + [2,] 1 0 0 1 0 0 1 0 1 + [3,] 1 0 0 0 0 0 0 0 0 + [4,] 0 0 0 0 0 0 0 0 0 + [,10] [,11] [,12] [,13] [,14] [,15] [,16] + [1,] 0 0 0 0 0 0 0 + [2,] 0 1 0 1 0 0 0 + [3,] 0 1 0 1 0 0 0 + [4,] 0 0 0 0 0 0 0 + [,17] [,18] [,19] [,20] [,21] [,22] + [1,] 0 0 0 0 0 0 + [2,] 0 1 0 0 0 0 + [3,] 0 0 0 0 0 0 + [4,] 0 0 0 0 0 0 + + diff --git a/tests/testthat/_snaps/kinship.md b/tests/testthat/_snaps/kinship.md new file mode 100644 index 00000000..d27bbb5a --- /dev/null +++ b/tests/testthat/_snaps/kinship.md @@ -0,0 +1,34 @@ +# kinship works with X chromosoms + + Code + kinship(ped2) + Output + 1 2 3 4 5 6 7 8 9 10 + 1 0.500 0.000 0.2500 0.2500 0.000 0.000 0.12500 0.12500 0.12500 0.12500 + 2 0.000 0.500 0.2500 0.2500 0.000 0.000 0.12500 0.12500 0.12500 0.12500 + 3 0.250 0.250 0.5000 0.2500 0.000 0.000 0.25000 0.12500 0.12500 0.18750 + 4 0.250 0.250 0.2500 0.5000 0.000 0.000 0.12500 0.25000 0.25000 0.18750 + 5 0.000 0.000 0.0000 0.0000 0.500 0.000 0.25000 0.00000 0.00000 0.12500 + 6 0.000 0.000 0.0000 0.0000 0.000 0.500 0.00000 0.25000 0.25000 0.12500 + 7 0.125 0.125 0.2500 0.1250 0.250 0.000 0.50000 0.06250 0.06250 0.28125 + 8 0.125 0.125 0.1250 0.2500 0.000 0.250 0.06250 0.50000 0.50000 0.28125 + 9 0.125 0.125 0.1250 0.2500 0.000 0.250 0.06250 0.50000 0.50000 0.28125 + 10 0.125 0.125 0.1875 0.1875 0.125 0.125 0.28125 0.28125 0.28125 0.53125 + +--- + + Code + kinship(ped2, chr = "X") + Output + 1 2 3 4 5 6 7 8 9 10 + 1 1.00 0.00 0.000 0.5000 0.000 0 0.0000 0.5000 0.5000 0.2500 + 2 0.00 0.50 0.500 0.2500 0.000 0 0.2500 0.2500 0.2500 0.2500 + 3 0.00 0.50 1.000 0.2500 0.000 0 0.5000 0.2500 0.2500 0.3750 + 4 0.50 0.25 0.250 0.5000 0.000 0 0.1250 0.5000 0.5000 0.3125 + 5 0.00 0.00 0.000 0.0000 0.500 0 0.2500 0.0000 0.0000 0.1250 + 6 0.00 0.00 0.000 0.0000 0.000 1 0.0000 0.0000 0.0000 0.0000 + 7 0.00 0.25 0.500 0.1250 0.250 0 0.5000 0.1250 0.1250 0.3125 + 8 0.50 0.25 0.250 0.5000 0.000 0 0.1250 1.0000 1.0000 0.5625 + 9 0.50 0.25 0.250 0.5000 0.000 0 0.1250 1.0000 1.0000 0.5625 + 10 0.25 0.25 0.375 0.3125 0.125 0 0.3125 0.5625 0.5625 0.5625 + diff --git a/tests/testthat/_snaps/kinship/twin-pedigree-2.svg b/tests/testthat/_snaps/kinship/twin-pedigree-2.svg new file mode 100644 index 00000000..434f5cce --- /dev/null +++ b/tests/testthat/_snaps/kinship/twin-pedigree-2.svg @@ -0,0 +1,38 @@ + + + + + + + + + + + + + +1 + +2 + +3 + +4 + + + + + + + + + + diff --git a/tests/testthat/_snaps/kinship/twin-pedigree.svg b/tests/testthat/_snaps/kinship/twin-pedigree.svg new file mode 100644 index 00000000..ceef38cb --- /dev/null +++ b/tests/testthat/_snaps/kinship/twin-pedigree.svg @@ -0,0 +1,117 @@ + + + + + + + + + + + + + +6 + +5 + +8 + +7 + +4 + +3 + +2 + +1 + +100 + +101 + +107 + +102 + +108 + +103 + +104 + +105 + +106 + +201 + +202 + +203 + +204 + +205 + +206 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/pedigree.shrink/pedigree-shrink-1.svg b/tests/testthat/_snaps/pedigree.shrink/pedigree-shrink-1.svg new file mode 100644 index 00000000..37087aa8 --- /dev/null +++ b/tests/testthat/_snaps/pedigree.shrink/pedigree-shrink-1.svg @@ -0,0 +1,442 @@ + + + + + + + + + + + + + + + + + + + + + + + + + +44 + + + + + + + + + + +45 + + + + + + + + + + + + + +70 + + + + + + + + + + + + + + + + + + + + + + + + + + + +54 + + + + + + + + + + + + + +46 + + + + + + + + + + +65 + + + + + + + + + + + + + +47 + + + + + + + + + + + + + +48 + +? + + + + + + + + + + +66 + + + + + + + + + + + +49 + + + + + + + + + + + + + +67 + + + + + + + + + + + +50 + + + + + + + + + + + +51 + + + + + + + + + + +52 + + + + + + + + + + + + +79 + + + + + + + + + + + +53 + + + + + + + + + + + + + +69 + +? + + + + + + + + + + + + +55 + + + + + + + + + + + + + +56 + + + + + + + + + + + +57 + + + + + + + + + + + + + +58 + +? + + + + + + + + + + + + +59 + + + + + + + + + + + +60 + + + + + + + + + + + +61 + +? + + + + + + + + + + + + +62 + + + + + + + + + + + +63 + + + + + + + + + + + +64 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/pedigree.shrink/pedigree-shrink-2.svg b/tests/testthat/_snaps/pedigree.shrink/pedigree-shrink-2.svg new file mode 100644 index 00000000..fd6d423e --- /dev/null +++ b/tests/testthat/_snaps/pedigree.shrink/pedigree-shrink-2.svg @@ -0,0 +1,481 @@ + + + + + + + + + + + + + + + + + + + + + + + + + +135 + + + + + + + + + + + +136 + + + + + + + + + + + + + +161 + + + + + + + + + + + + + + + + + + + + + + + + + + +142 + + + + + + + + + + + + + +143 + + + + + + + + + + + +162 + + + + + + + + + + + + + +144 + + + + + + + + + + + + + +163 + + + + + + + + + + + +145 + + + + + + + + + + + +146 + + + + + + + + + + + + + +165 + + + + + + + + + + +147 + + + + + + + + + + + + +166 + + + + + + + + + + + +148 + + + + + + + + + + + + + +137 + + + + + + + + + + + + + +138 + + + + + + + + + + + +159 + + + + + + + + + + + + + +139 + + + + + + + + + + + + + +140 + + + + + + + + + + + +141 + + + + + + + + + + + +149 + + + + + + + + + + + + + +150 + + + + + + + + + + + + +151 + + + + + + + + + + +152 + + + + + + + + + + + +153 + + + + + + + + + + + + + +154 + + + + + + + + + + + +155 + +? + + + + + + + + + + + + +156 + + + + + + + + + + + +157 + + + + + + + + + + + +158 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/pedigree.unrelated/pedigree-unrelated-1.svg b/tests/testthat/_snaps/pedigree.unrelated/pedigree-unrelated-1.svg new file mode 100644 index 00000000..21140212 --- /dev/null +++ b/tests/testthat/_snaps/pedigree.unrelated/pedigree-unrelated-1.svg @@ -0,0 +1,376 @@ + + + + + + + + + + + + + +? + +105 + +? + +106 + + +107 + + +108 + +? + +135 + +? + +136 + + +101 + + +102 + + +115 + + +117 + + + + + + + + + +116 + + + + + + + + + +118 + + + + + + + + + + + +119 + + +120 + + +103 + + +104 + +? + +137 + +? + +138 + + + + + + + + + +109 + + + + + + + + + + +110 + + + + + + + + + + + +129 + + + + + + + + + + + +130 + + +131 + + +132 + + + + + + + + + +133 + + +134 + + + + + + + + + + + +110 + + +111 + + +112 + + + + + + + + + +118 + + +114 + + +115 + + +139 + + + + + + + + + +140 + + + + + + + + + +141 + + +121 + + +122 + + +123 + + + + + + + + + + +124 + + + + + + + + + +125 + + + + + + + + + +126 + + + + + + + + + + + +127 + + + + + + + + + + +128 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/pedigree/ped1.svg b/tests/testthat/_snaps/pedigree/ped1.svg new file mode 100644 index 00000000..8e963a4c --- /dev/null +++ b/tests/testthat/_snaps/pedigree/ped1.svg @@ -0,0 +1,201 @@ + + + + + + + + + + + + + +? +105 + +? +106 + +107 + +108 + +? +135 + +? +136 + +101 + +102 + +115 + +117 + +116 + +118 + +119 + +120 + +103 + +104 + +? +137 + +? +138 + +109 + +110 + +129 + +130 + +131 + +132 + +133 + +134 + +110 + +111 + +112 + +118 + +114 + +115 + +139 + +140 + +141 + +121 + +122 + +123 + +124 + +125 + +126 + +127 + +128 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/pedigree/ped1reorder.svg b/tests/testthat/_snaps/pedigree/ped1reorder.svg new file mode 100644 index 00000000..21da28d0 --- /dev/null +++ b/tests/testthat/_snaps/pedigree/ped1reorder.svg @@ -0,0 +1,198 @@ + + + + + + + + + + + + + +? +135 + +? +136 + +? +105 + +? +106 + +107 + +108 + +? +137 + +? +138 + +103 + +104 + +101 + +102 + +115 + +117 + +116 + +118 + +119 + +120 + +139 + +140 + +141 + +111 + +112 + +118 + +114 + +115 + +110 + +109 + +129 + +130 + +131 + +132 + +133 + +134 + +125 + +126 + +127 + +128 + +121 + +122 + +123 + +124 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/test-align.R b/tests/testthat/test-align.R new file mode 100644 index 00000000..1616a05c --- /dev/null +++ b/tests/testthat/test-align.R @@ -0,0 +1,9 @@ +test_that("align.pedigree works", { + data("sample.ped") + ped <- with(sample.ped, pedigree(id, father, mother, sex)) + withr::local_options(width = 50) + expect_snapshot(align.pedigree(ped)) + align <- align.pedigree(ped) + expect_equal(align$n, c(8,19,22,8)) +}) + diff --git a/tests/testthat/test-fixParents.R b/tests/testthat/test-fixParents.R new file mode 100644 index 00000000..b9ad0db4 --- /dev/null +++ b/tests/testthat/test-fixParents.R @@ -0,0 +1,34 @@ +test_that("fixParents works with number", { + materdf <- data.frame(id = 1:5, momid = c(0, 1, 1, 2, 2), sex = 2) + + materdf$dadid <- materdf$momid * 100 + expect_error(with(materdf, pedigree(id, dadid, momid, sex))) + peddf <- with(materdf, fixParents(id, dadid, momid, sex)) + expect_no_error(with(peddf, pedigree(id, dadid, momid, sex))) +}) + +test_that("fixParrents works with character", { + test1char <- data.frame( + id = paste("fam", 101:111, sep = ""), + sex = c("male", "female")[c(1, 2, 1, 2, 1, 1, 2, 2, 1, 2, 1)], + father = c(0, 0, "fam101", "fam101", "fam101", 0, 0, "fam106", "fam106", "fam106", "fam109"), + mother = c(0, 0, "fam102", "fam102", "fam102", 0, 0, "fam107", "fam107", "fam107", "fam112") + ) + expect_error(with(test1char, pedigree(id, father, mother, sex, missid = "0"))) + test1newmom <- with(test1char, fixParents(id, father, mother, sex, missid = "0")) + expect_no_error(with(test1newmom, pedigree(id, dadid, momid, sex, missid = "0"))) +}) + +test_that("fixParrents works with sex errors", { + data(sample.ped) + datped2 <- sample.ped[sample.ped$ped %in% 2, ] + datped2[datped2$id %in% 203, "sex"] <- 2 + datped2 <- datped2[-which(datped2$id %in% 209), ] + + ## this gets an error + expect_error(with(datped2, pedigree(id, father, mother, sex))) + + ## This fix the error + fixped2 <- with(datped2, fixParents(id, father, mother, sex)) + expect_no_error(with(fixped2, pedigree(id, dadid, momid, sex))) +}) diff --git a/tests/testthat/test-kinship.R b/tests/testthat/test-kinship.R new file mode 100644 index 00000000..563bc73c --- /dev/null +++ b/tests/testthat/test-kinship.R @@ -0,0 +1,190 @@ +test_that("kinship works", { + twindat <- c( + 1, 3, 4, 2, + 2, 0, 0, 1, + 3, 8, 7, 1, + 4, 6, 5, 2, + 5, 0, 0, 2, + 6, 0, 0, 1, + 7, 0, 0, 2, + 8, 0, 0, 1, + 100, 3, 4, 1, + 101, 3, 4, 2, + 102, 3, 4, 2, + 103, 3, 4, 2, + 104, 3, 4, 2, + 105, 3, 4, 2, + 106, 3, 4, 2, + 107, 0, 0, 1, + 108, 0, 0, 1, + 201, 2, 1, 1, + 202, 2, 1, 1, + 203, 2, 1, 1, + 204, 2, 1, 1, + 205, 107, 102, 1, + 206, 108, 103, 2 + ) + twindat <- matrix(twindat, ncol = 4, byrow = TRUE) + dimnames(twindat) <- list(NULL, c("id", "dadid", "momid", "sex")) + twindat <- data.frame(twindat) + + relate <- data.frame( + id1 = c(101, 102, 101, 104, 203), + id2 = c(102, 103, 103, 105, 204), + code = c(1, 1, 1, 2, 1) + ) + + tped <- with(twindat, pedigree(id, dadid, momid, sex, + relation=relate)) + + expect_doppelganger("Twin pedigree", + plot(tped)) + + kmat <- kinship(tped) + + ## should show kinship coeff of 0.5 for where MZ twins are + ## ids: 102-103 and 203-204 + expect_true(all(kmat[c("102","101","103"),c("102","101","103")]==0.5)) + expect_true(all(kmat[c("203","204"),c("203","204")]==0.5)) + + # Renumber everyone as 1,2,....; makes the all.equal checks easier + indx <- sort(unique(unlist(twindat[, 1:3]))) + twindat$id <- match(twindat$id, indx) - 1 + twindat$dadid <- match(twindat$dadid, indx) - 1 + twindat$momid <- match(twindat$momid, indx) - 1 + relate$id1 <- match(relate$id1, indx) - 1 + relate$id2 <- match(relate$id2, indx) - 1 + + # Build the pedigree and kinship + tped <- with(twindat, pedigree(id, dadid, momid, sex, + relation = relate + )) + kmat <- kinship(tped) + + truth <- matrix( + c( + 5, 6, 0, + 5, 4, .25, # parent child + 10, 11, .5, # mz twins + 22, 12, .25, # aunt, mz with mother + 22, 13, .125, # aunt, dz + 13, 14, .25, # dz twins + 20, 21, .5, # mz twins + 19, 16, 0, # marry in uncle + 19, 11, .125, # aunt who is a twin + 19, 3, .125 + ), # grandmother + byrow = TRUE, ncol = 3 + ) + expect_equal(kmat[truth[, 1:2]], truth[, 3]) +}) + +test_that("Kinship Claus Ekstrom 09/2012", { + ## simple test case for kinship of MZ twins from Claus Ekstrom, 9/2012 + mydata <- data.frame(id=1:4, dadid=c(NA, NA, 1, 1), + momid=c(NA, NA, 2, 2), sex=c("male", "female", "male", "male"), + famid=c(1,1,1,1)) + relation <- data.frame(id1=c(3), id2=c(4), famid=c(1), code=c(1)) + + ped <- pedigree(id=mydata$id, dadid=mydata$dadid, momid=mydata$momid, sex=mydata$sex, relation=relation) + + expect_doppelganger("Twin pedigree 2", plot(ped)) + + kmat <- kinship(ped) + expect_true(all(kmat[3:4,3:4]==0.5)) +}) + + + + +test_that("kinship works with X chromosoms", { + ## test pedigree from bioinformatics manuscript + ## try x-chrom kinship + ## also has inbreeding and twins, for quick check + ped2mat <- matrix(c( + 1, 1, 0, 0, 1, + 1, 2, 0, 0, 2, + 1, 3, 1, 2, 1, + 1, 4, 1, 2, 2, + 1, 5, 0, 0, 2, + 1, 6, 0, 0, 1, + 1, 7, 3, 5, 2, + 1, 8, 6, 4, 1, + 1, 9, 6, 4, 1, + 1, 10, 8, 7, 2 + ), ncol = 5, byrow = TRUE) + + ped2df <- as.data.frame(ped2mat) + names(ped2df) <- c("fam", "id", "dad", "mom", "sex") + ## 1 2 3 4 5 6 7 8 9 10,11,12,13,14,15,16 + ped2df$disease <- c(NA, NA, 1, 0, 0, 0, 0, 1, 1, 1) + ped2df$smoker <- c(0, NA, 0, 0, 1, 1, 1, 0, 0, 0) + ped2df$availstatus <- c(0, 0, 1, 1, 0, 1, 1, 1, 1, 1) + ped2df$vitalstatus <- c(1, 1, 1, 0, 1, 0, 0, 0, 0, 0) + + ped2 <- with(ped2df, pedigree(id, dad, mom, sex, + status = vitalstatus, + affected = cbind(disease, smoker, availstatus), relation = matrix(c(8, 9, 1), ncol = 3) + )) + + ## regular kinship matrix + expect_snapshot(kinship(ped2)) + expect_snapshot(kinship(ped2, chr = "X")) + + ped3 <- ped2 + ped3$sex[9] <- "unknown" + + ## regular again, should be same as above + expect_equal(kinship(ped2), kinship(ped3)) + + ## now with unknown sex, gets NAs + k3 <- kinship(ped3, chrtype = "X") + expect_true(all(is.na(k3[9, ]))) + + # all descendants of sex=unknown to be NAs as well + ped3$sex[8] <- "unknown" + k4 <- kinship(ped3, chr = "X") + expect_true(all(is.na(k4[8:10, ]))) +}) + +test_that("Kinship with 2 different family", { + ped2mat <- matrix(c( + 1, 1, 0, 0, 1, + 1, 2, 0, 0, 2, + 1, 3, 1, 2, 1, + 1, 4, 1, 2, 2, + 1, 5, 0, 0, 2, + 1, 6, 0, 0, 1, + 1, 7, 3, 5, 2, + 1, 8, 6, 4, 1, + 1, 9, 6, 4, 1, + 1, 10, 8, 7, 2 + ), ncol = 5, byrow = TRUE) + + ped2df <- as.data.frame(ped2mat) + names(ped2df) <- c("fam", "id", "dad", "mom", "sex") + ## 1 2 3 4 5 6 7 8 9 10,11,12,13,14,15,16 + ped2df$disease <- c(NA, NA, 1, 0, 0, 0, 0, 1, 1, 1) + ped2df$smoker <- c(0, NA, 0, 0, 1, 1, 1, 0, 0, 0) + ped2df$availstatus <- c(0, 0, 1, 1, 0, 1, 1, 1, 1, 1) + ped2df$vitalstatus <- c(1, 1, 1, 0, 1, 0, 0, 0, 0, 0) + + ## testing kinship2 on pedigreeList when only one subject in a family + peddf <- rbind(ped2df, c(2, 1, 0, 0, 1, 1, 0, 1, 0)) + + peds <- with(peddf, pedigree(id, dad, mom, sex, + status = vitalstatus, fam = fam, + affected = cbind(disease, smoker, availstatus) + )) + kinfam <- kinship(peds) + expect_true(all(kinfam["2/1", 1:10] == 0)) + + ## now add two more for ped2, and check again + peddf <- rbind(peddf, c(2, 2, 0, 0, 2, 1, 0, 1, 0), c(2, 3, 1, 2, 1, 1, 0, 1, 0)) + peds <- with(peddf, pedigree(id, dad, mom, sex, + status = vitalstatus, fam = fam, + affected = cbind(disease, smoker, availstatus) + )) + kin2fam <- kinship(peds) + expect_true(all(kin2fam[11:13, 1:10] == 0)) +}) diff --git a/tests/testthat/test-makefamid.R b/tests/testthat/test-makefamid.R new file mode 100644 index 00000000..77b8e5f5 --- /dev/null +++ b/tests/testthat/test-makefamid.R @@ -0,0 +1,8 @@ +test_that("makefamid works", { + id <- 1:20 + mom <- c(0,0,0,2,2,2,0,2,0, 0,2,2,0,2,0,2, 7,7, 11,14) + dad <- c(0,0,0,1,1,1,0,1,0, 0,3,3,0,3,0,3, 8,8, 10,13) + famid <- c(1,1,1,1,1,1,1,1,0,1,1,1,1,1,0,1,1,1,1,1) + temp<- makefamid(id, mom, dad) + expect_equal(temp, famid) +}) diff --git a/tests/testthat/test-pedigree.R b/tests/testthat/test-pedigree.R new file mode 100644 index 00000000..705a8d3e --- /dev/null +++ b/tests/testthat/test-pedigree.R @@ -0,0 +1,41 @@ +test_that("pedigree fails to line up", { + # Here is a case where the levels fail to line up properly + data(sample.ped) + df1 <- sample.ped[sample.ped$ped == 1, ] + ped1 <- with(df1, pedigree(id, father, mother, sex, affected)) + expect_doppelganger("ped1", plot(ped1)) + + # With reordering it's better + df1reord <- df1[c(35:41, 1:34), ] + ped1reord <- with(df1reord, pedigree(id, father, mother, + sex, + affected = affected + )) + expect_doppelganger("ped1reorder", plot(ped1reord)) +}) + +test_that("pedigree subscripting", { + data(minnbreast) + + minnped <- with(minnbreast, pedigree(id, fatherid, motherid, sex, + affected = cancer, famid = famid + )) + ped8 <- minnped["8"] # a modest sized family + + # Subjects 150, 152, 154, 158 are children, + # and 143, 162, 149 are parents and a child + droplist <- c(150, 152, 154, 158, 143, 162, 149) + + keep1 <- !(ped8$id %in% droplist) # logical + keep2 <- which(keep1) # numeric + keep3 <- as.character(ped8$id[keep1]) # character + keep4 <- factor(keep3) + + test1 <- ped8[keep1] + test2 <- ped8[keep2] + test3 <- ped8[keep3] + test4 <- ped8[keep4] + expect_equal(test1, test2) + expect_equal(test1, test3) + expect_equal(test1, test4) +}) diff --git a/tests/testthat/test-pedigree.shrink.R b/tests/testthat/test-pedigree.shrink.R new file mode 100644 index 00000000..5c9b9eeb --- /dev/null +++ b/tests/testthat/test-pedigree.shrink.R @@ -0,0 +1,115 @@ +## example data and test steps from pedigree.shrink +## Jason Sinnwell + +test_that("Pedigree shrink works", { + data(minnbreast) + pedMN <- with(minnbreast, pedigree(id, fatherid, motherid, sex, + famid = famid, + affected = cbind(cancer, bcpc, proband) + )) + + ## this pedigree as one person with cancer. The pedigree is not informative + ## if they are the only available, so pedigree.shrink trims all. + ## This caused an error in pedigree.shrink before kinship2. v1.2.8. Now fixed + mn2 <- pedMN[2] + expect_doppelganger("pedigree shrink 1", plot(mn2)) + + ## breaks in pedigree.trim + shrink.mn2 <- pedigree.shrink(mn2, + avail = ifelse(is.na(mn2$affected[, 1]), 0, mn2$affected[, 1]) + ) + + expect_equal(shrink.mn2$idList$unavail, + c(44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, + 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, + 76, 77, 78, 79, 26050, 26051)) + + mnf8 <- pedMN["8"] + expect_doppelganger("pedigree shrink 2", plot(mnf8)) + + shrink.mnf8 <- pedigree.shrink(mnf8, + avail = ifelse(is.na(mnf8$affected[, 1]), 0, mnf8$affected[, 1]) + ) + + expect_equal(shrink.mnf8$idList$unavail, + c(137, 138, 139, 140, 144, 145, 146, 147, 148, 150, 151, 152, + 153, 154, 155, 156, 157, 158, 159, 160, 163, 164, 165, 166, 167, + 168, 169, 170, 171, 172, 173, 174)) +}) + +test_that("Pedigree shrink error if missing info", { + ## use sample.ped from the package + data(sample.ped) + + pedAll <- pedigree(sample.ped$id, sample.ped$father, sample.ped$mother, + sample.ped$sex, + affected = cbind(sample.ped$affected, sample.ped$avail), + famid = sample.ped$ped + ) + ped2 <- pedAll["2"] + ped2$sex[c(13, 12)] <- c("unknown", "terminated") + + ## set 2nd col of affected to NA + ped2$affected[c(7, 9), 2] <- NA + expect_error(pedigree.shrink(ped = ped2, avail = ped2$affected[, 2], maxBits = 32)) +}) + +test_that("Pedigree shrink avail test", { + + ## use sample.ped from the package + data(sample.ped) + + pedAll <- pedigree(sample.ped$id, sample.ped$father, sample.ped$mother, + sample.ped$sex, + affected = cbind(sample.ped$affected, sample.ped$avail), + famid = sample.ped$ped + ) + ped1 <- pedAll["1"] + + set.seed(10) + shrink1.avail.B32 <- pedigree.shrink(ped = ped1, avail = ped1$affected[, 2], maxBits = 32) + + set.seed(10) + shrink1.avail.B25 <- pedigree.shrink(ped = ped1, avail = ped1$affected[, 2], maxBits = 25) + + expect_equal(shrink1.avail.B32$idTrimmed, + c(101, 102, 107, 108, 111, 113, 121, 122, 123, 131, 132, 134, 139)) + + expect_equal(shrink1.avail.B25$idTrimmed, + c(101, 102, 107, 108, 111, 113, 121, 122, 123, 131, 132, 134, 139, 140, 141)) +}) + +test_that("Pedigree shrink with character", { + ## use sample.ped from the package + data(sample.ped) + + pedAll <- pedigree(sample.ped$id, sample.ped$father, sample.ped$mother, + sample.ped$sex, + affected = cbind(sample.ped$affected, sample.ped$avail), + famid = sample.ped$ped + ) + + # Select first family + ped1 <- pedAll["1"] + ped1df <- as.data.frame(ped1) + + # Change id to character + ped1df$idchar <- gsub("^1", "A-", as.character(ped1df$id)) + ped1df$dadidchar <- gsub("^1", "A-", as.character(ped1df$dadid)) + ped1df$momidchar <- gsub("^1", "A-", as.character(ped1df$momid)) + # ped1df$dadidchar <- ifelse(ped1df$dadidchar=="0", NA, ped1df$dadidchar) + # ped1df$momidchar <- ifelse(ped1df$momidchar=="0", NA, ped1df$momidchar) + ped1char <- with(ped1df, pedigree(idchar, dadidchar, momidchar, sex, affected, missid = c("0"))) + + set.seed(100) + shrink1.p1char.B32 <- pedigree.shrink(ped = ped1char, avail = ped1char$affected[, 2], maxBits = 32) + expect_equal(shrink1.p1char.B32$idTrimmed, + c("A-01", "A-02", "A-07", "A-08", "A-11", "A-13", "A-21", "A-22", + "A-23", "A-31", "A-32", "A-34", "A-39")) + + set.seed(100) + shrink1.p1char.B25 <- pedigree.shrink(ped = ped1char, avail = ped1char$affected[, 2], maxBits = 25) + expect_equal(shrink1.p1char.B25$idTrimmed, + c("A-01", "A-02", "A-07", "A-08", "A-11", "A-13", "A-21", "A-22", + "A-23", "A-31", "A-32", "A-34", "A-39", "A-33", "A-41")) +}) diff --git a/tests/testthat/test-pedigree.unrelated.R b/tests/testthat/test-pedigree.unrelated.R new file mode 100644 index 00000000..9edb4eec --- /dev/null +++ b/tests/testthat/test-pedigree.unrelated.R @@ -0,0 +1,26 @@ +test_that("Pedigree unrelated", { + data(sample.ped) + + pedAll <- pedigree(sample.ped$id, sample.ped$father, sample.ped$mother, + sample.ped$sex, + famid = sample.ped$ped, + affected = cbind(sample.ped$affected, sample.ped$avail) + ) + + ped1 <- pedAll["1"] + ped2 <- pedAll["2"] + + ## to see plot: + expect_doppelganger("Pedigree unrelated 1", plot.pedigree(ped1, align = FALSE)) + set.seed(10) + expect_equal( + pedigree.unrelated(ped1, avail = ped1$affected[, 2]), + c("109", "113", "133", "141") + ) + + set.seed(10) + expect_equal( + pedigree.unrelated(ped2, avail = ped2$affected[, 2]), + c("203", "206") + ) +}) diff --git a/tests/twin.R b/tests/twin.R deleted file mode 100644 index 061eef23..00000000 --- a/tests/twin.R +++ /dev/null @@ -1,63 +0,0 @@ -require(kinship2) -# -# Test some twins data from Curtis Oswold -# -twindat <- c(1,3,4,2, - 2,0,0,1, - 3,8,7,1, - 4,6,5,2, - 5,0,0,2, - 6,0,0,1, - 7,0,0,2, - 8,0,0,1, - 100,3,4,1, - 101,3,4,2, - 102,3,4,2, - 103,3,4,2, - 104,3,4,2, - 105,3,4,2, - 106,3,4,2, - 107,0,0,1, - 108,0,0,1, - 201,2,1,1, - 202,2,1,1, - 203,2,1,1, - 204,2,1,1, - 205,107,102,1, - 206,108,103,2) -twindat <- matrix(twindat, ncol=4, byrow=T) -dimnames(twindat) <- list(NULL, c('id', 'dadid', 'momid', 'sex')) -twindat <- data.frame(twindat) - -## set up a fraternal twin set, and a set of triplets with kids from -## their marriages to test kinship coeff -relate=data.frame(id1=c(101,102,104,203), id2=c(102,103,105,204), code=c(1,1,2,1)) - -tped <- with(twindat, pedigree(id, dadid, momid, sex, - relation=relate)) - - -## plot(tped) - -## should show kinship coeff of 0.5 for where MZ twins are -## ids: 102-103 and 203-204 -kinmat <- kinship(tped) - -kinmat[c(10:16,19:23),c(10:16,19:23)] - - - - -## simple test case for kinship of MZ twins from Claus Ekstrom, 9/2012 -mydata <- data.frame(id=1:4, dadid=c(NA, NA, 1, 1), -momid=c(NA, NA, 2, 2), sex=c("male", "female", "male", "male"), -famid=c(1,1,1,1)) -relation <- data.frame(id1=c(3), id2=c(4), famid=c(1), code=c(1)) - -x <- pedigree(id=mydata$id, dadid=mydata$dadid, momid=mydata$momid, sex=mydata$sex, relation=relation) - -#plot(x) - -kinout <- kinship(x) -kinship2:::kinship.pedigree(x) - diff --git a/tests/twin.Rout.save b/tests/twin.Rout.save deleted file mode 100644 index 4c455178..00000000 --- a/tests/twin.Rout.save +++ /dev/null @@ -1,107 +0,0 @@ - -R Under development (unstable) (2022-09-11 r82834) -- "Unsuffered Consequences" -Copyright (C) 2022 The R Foundation for Statistical Computing -Platform: x86_64-pc-linux-gnu (64-bit) - -R is free software and comes with ABSOLUTELY NO WARRANTY. -You are welcome to redistribute it under certain conditions. -Type 'license()' or 'licence()' for distribution details. - - Natural language support but running in an English locale - -R is a collaborative project with many contributors. -Type 'contributors()' for more information and -'citation()' on how to cite R or R packages in publications. - -Type 'demo()' for some demos, 'help()' for on-line help, or -'help.start()' for an HTML browser interface to help. -Type 'q()' to quit R. - -> require(kinship2) -Loading required package: kinship2 -Loading required package: Matrix -Loading required package: quadprog -> # -> # Test some twins data from Curtis Oswold -> # -> twindat <- c(1,3,4,2, -+ 2,0,0,1, -+ 3,8,7,1, -+ 4,6,5,2, -+ 5,0,0,2, -+ 6,0,0,1, -+ 7,0,0,2, -+ 8,0,0,1, -+ 100,3,4,1, -+ 101,3,4,2, -+ 102,3,4,2, -+ 103,3,4,2, -+ 104,3,4,2, -+ 105,3,4,2, -+ 106,3,4,2, -+ 107,0,0,1, -+ 108,0,0,1, -+ 201,2,1,1, -+ 202,2,1,1, -+ 203,2,1,1, -+ 204,2,1,1, -+ 205,107,102,1, -+ 206,108,103,2) -> twindat <- matrix(twindat, ncol=4, byrow=T) -> dimnames(twindat) <- list(NULL, c('id', 'dadid', 'momid', 'sex')) -> twindat <- data.frame(twindat) -> -> ## set up a fraternal twin set, and a set of triplets with kids from -> ## their marriages to test kinship coeff -> relate=data.frame(id1=c(101,102,104,203), id2=c(102,103,105,204), code=c(1,1,2,1)) -> -> tped <- with(twindat, pedigree(id, dadid, momid, sex, -+ relation=relate)) -> -> -> ## plot(tped) -> -> ## should show kinship coeff of 0.5 for where MZ twins are -> ## ids: 102-103 and 203-204 -> kinmat <- kinship(tped) -> -> kinmat[c(10:16,19:23),c(10:16,19:23)] - 101 102 103 104 105 106 107 202 203 204 205 206 -101 0.500 0.500 0.500 0.250 0.250 0.250 0.00 0.1250 0.1250 0.1250 0.2500 0.2500 -102 0.500 0.500 0.500 0.250 0.250 0.250 0.00 0.1250 0.1250 0.1250 0.2500 0.2500 -103 0.500 0.500 0.500 0.250 0.250 0.250 0.00 0.1250 0.1250 0.1250 0.2500 0.2500 -104 0.250 0.250 0.250 0.500 0.250 0.250 0.00 0.1250 0.1250 0.1250 0.1250 0.1250 -105 0.250 0.250 0.250 0.250 0.500 0.250 0.00 0.1250 0.1250 0.1250 0.1250 0.1250 -106 0.250 0.250 0.250 0.250 0.250 0.500 0.00 0.1250 0.1250 0.1250 0.1250 0.1250 -107 0.000 0.000 0.000 0.000 0.000 0.000 0.50 0.0000 0.0000 0.0000 0.2500 0.0000 -202 0.125 0.125 0.125 0.125 0.125 0.125 0.00 0.5000 0.2500 0.2500 0.0625 0.0625 -203 0.125 0.125 0.125 0.125 0.125 0.125 0.00 0.2500 0.5000 0.5000 0.0625 0.0625 -204 0.125 0.125 0.125 0.125 0.125 0.125 0.00 0.2500 0.5000 0.5000 0.0625 0.0625 -205 0.250 0.250 0.250 0.125 0.125 0.125 0.25 0.0625 0.0625 0.0625 0.5000 0.1250 -206 0.250 0.250 0.250 0.125 0.125 0.125 0.00 0.0625 0.0625 0.0625 0.1250 0.5000 -> -> -> -> -> ## simple test case for kinship of MZ twins from Claus Ekstrom, 9/2012 -> mydata <- data.frame(id=1:4, dadid=c(NA, NA, 1, 1), -+ momid=c(NA, NA, 2, 2), sex=c("male", "female", "male", "male"), -+ famid=c(1,1,1,1)) -> relation <- data.frame(id1=c(3), id2=c(4), famid=c(1), code=c(1)) -> -> x <- pedigree(id=mydata$id, dadid=mydata$dadid, momid=mydata$momid, sex=mydata$sex, relation=relation) -> -> #plot(x) -> -> kinout <- kinship(x) -> kinship2:::kinship.pedigree(x) - 1 2 3 4 -1 0.50 0.00 0.25 0.25 -2 0.00 0.50 0.25 0.25 -3 0.25 0.25 0.50 0.50 -4 0.25 0.25 0.50 0.50 -> -> -> proc.time() - user system elapsed - 2.181 0.141 2.397