-
Notifications
You must be signed in to change notification settings - Fork 3
/
convertRelationships.R
101 lines (96 loc) · 3.83 KB
/
convertRelationships.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
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
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
#' Converts pairwise kinship values to a relationship category descriptor.
#'
## Copyright(c) 2017-2020 R. Mark Sharp
## This file is part of nprcgenekeepr
#' Part of Relations
#'
#' @return A dataframe with columns \code{id1}, \code{id2}, \code{kinship},
#' \code{relation}. It is a long-form table of pairwise kinships, with
#' relationship categories included for each pair.
#'
#' @examples
#' \donttest{
#' library(nprcgenekeepr)
#' ped <- nprcgenekeepr::smallPed
#' kmat <- kinship(ped$id, ped$sire, ped$dam, ped$gen, sparse = FALSE)
#' ids <- c("A", "B", "D", "E", "F", "G", "I", "J", "L", "M", "O", "P")
#' relIds <- convertRelationships(kmat, ped, ids)
#' rel <- convertRelationships(kmat, ped, updateProgress = function() {})
#' head(rel)
#' ped <- nprcgenekeepr::qcPed
#' bkmat <- kinship(ped$id, ped$sire, ped$dam, ped$gen,
#' sparse = FALSE)
#' relBIds <- convertRelationships(bkmat, ped, c("4LFS70", "DD1U77"))
#' relBIds
#' }
#'
#' @param kmat a numeric matrix of pairwise kinship coefficients.
#' Rows and columns should be named with IDs.
#' @param ped the pedigree information in datatable format with required
#' colnames \code{id}, \code{sire}, and \code{dam}.
#' @param ids character vector of IDs or NULL to which the analysis should be
#' restricted. If provided, only relationships between these IDs will be
#' converted to relationships.
#' @param updateProgress function or NULL. If this function is defined, it
#' will be called during each iteration to update a
#' \code{shiny::Progress} object.
#' @export
convertRelationships <- function(kmat, ped, ids = NULL, updateProgress = NULL) {
if (!is.null(ids)) {
kmat <- filterKinMatrix(ids, kmat)
}
kin <- kinMatrix2LongForm(kmat, rm.dups = TRUE)
ped <- makeCEPH(ped$id, ped$sire, ped$dam)
r <- c()
for (i in seq_len(nrow(kin))) {
id1 <- kin$id1[i]
id2 <- kin$id2[i]
ceph1 <- ped[[id1]]
ceph2 <- ped[[id2]]
if (id1 == id2) {
relation <- "Self"
} else if (allTrueNoNA(ceph1$parents == ceph2$parents)) {
relation <- "Full-Siblings"
} else if (id1 %in% ceph2$parents | id2 %in% ceph1$parents) {
# one animal is the parent of the other
relation <- "Parent-Offspring"
} else if (!isEmpty(intersect(ceph1$parents, ceph2$parents))) {
# at least 1 parent is shared
relation <- "Half-Siblings"
} else if (id1 %in% c(ceph2$pgp, ceph2$mgp) |
id2 %in% c(ceph1$pgp, ceph1$mgp)) {
# one animals is the grandparent of the other
relation <- "Grandparent-Grandchild"
} else if (allTrueNoNA(ceph1$pgp == ceph2$pgp) |
allTrueNoNA(ceph1$pgp == ceph2$mgp) |
allTrueNoNA(ceph1$mgp == ceph2$pgp) |
allTrueNoNA(ceph1$mgp == ceph2$mgp)) {
# When a full set of grandparents are shared
relation <- "Full-Cousins"
} else if (!isEmpty(intersect(c(ceph1$pgp, ceph1$mgp),
c(ceph2$pgp, ceph2$mgp)))) {
# When at least one grandparent is in common
relation <- "Cousin - Other"
} else if (allTrueNoNA(ceph1$parents == ceph2$pgp) |
allTrueNoNA(ceph1$parents == ceph2$mgp) |
allTrueNoNA(ceph2$parents == ceph1$pgp) |
allTrueNoNA(ceph2$parents == ceph1$mgp)) {
# When parents of one proband are the grandparents of the other
relation <- "Full-Avuncular"
} else if (!isEmpty(intersect(ceph1$parents, c(ceph2$pgp, ceph2$mgp))) |
!isEmpty(intersect(ceph2$parents, c(ceph1$pgp, ceph1$mgp)))) {
# When at least one parent of a proband is the grandparent of the other
relation <- "Avuncular - Other"
} else if (kin$kinship[i] > 0) {
relation <- "Other"
} else {
relation <- "No Relation"
}
r <- c(r, relation)
if (!is.null(updateProgress)) {
updateProgress()
}
}
kin["relation"] <- r
return(kin)
}