├── Content ├── Chapter_04 │ ├── Chapter_04_1.R │ ├── Chapter_04_2.R │ └── Chapter_04_3.R ├── Chapter_05 │ ├── Chapter_05_1.R │ └── Chapter_05_2.R ├── Chapter_06 │ └── Chapter_06.R ├── Chapter_08 │ └── Chapter_08.R ├── Chapter_09 │ ├── Chapter_09_1.R │ └── Chapter_09_2.R ├── Chapter_10 │ └── Chapter_10.R ├── Chapter_11 │ ├── Chapter_11_1.R │ ├── Chapter_11_2.R │ └── Chapter_11_3.R ├── Chapter_12 │ ├── APY_fja.R │ ├── Chapter_12_1.R │ └── Chapter_12_2.R ├── Chapter_13 │ ├── Chapter_13_1.R │ ├── Chapter_13_2.R │ └── ped_snp.txt ├── Chapter_14 │ └── Chapter_14.R ├── Chapter_15 │ ├── Chapter_15_1.R │ ├── Chapter_15_2.R │ ├── Chapter_15_3.R │ └── threshold_fja.R ├── Chapter_17 │ └── Chapter_17.R ├── Chapter_18 │ └── Chapter_18.R └── Chapter_19 │ └── Chapter_19.R └── README.md /Content/Chapter_04/Chapter_04_1.R: -------------------------------------------------------------------------------- 1 | # Chapter 4 2 | ## A Model for an Animal Evaluation (Animal Model) 3 | ## Accuracy of evaluations 4 | ## A Sire Model 5 | 6 | # Clean the working environment 7 | rm(list = ls()) 8 | 9 | # Load packages 10 | library("pedigreemm") 11 | library("tidyverse") 12 | # install.packages("pedigreemm") 13 | # install.packages("tidyverse") 14 | 15 | # Example 4.1 ------------------------------------------------------------- 16 | 17 | # Prepare pedigree 18 | a = seq(1, 8) 19 | s = c(NA, NA, NA, 1, 3, 1, 4, 3) 20 | d = c(NA, NA, NA, NA, 2, 2, 5, 6) 21 | ped = data.frame(a, s, d) 22 | 23 | pedX = pedigree(label = a, 24 | sire = s, 25 | dam = d) 26 | 27 | Ainv = getAInv(ped = pedX) 28 | 29 | # Prepare data 30 | wwg = c(NA, NA, NA, 4.5, 2.9, 3.9, 3.5, 5.0) 31 | sex = c("Male", "Female", "Male", "Male", "Female", "Female", "Male", "Male") 32 | 33 | data = data.frame(a, s, d, sex, wwg) 34 | 35 | data$sex = as.factor(sex) 36 | data$sex = relevel(factor(sex), ref = "Male") 37 | data$a = factor(x = data$a, levels = pedX@label) 38 | 39 | # Variance components 40 | varA = 20 41 | varE = 40 42 | 43 | # Variance ratios 44 | alpha = varE/varA 45 | 46 | # Setting up the incidence matrices for the MME 47 | X = model.matrix(wwg ~ -1 + sex, data = data) 48 | 49 | Z = model.matrix(wwg ~ a - 1, data = data) 50 | 51 | y = na.omit(data$wwg) 52 | 53 | XpX = crossprod(X) 54 | XpZ = crossprod(X, Z) 55 | ZpX = crossprod(Z, X) 56 | ZpZ = crossprod(Z) 57 | Xpy = crossprod(X, y) 58 | Zpy = crossprod(Z, y) 59 | 60 | LHS = rbind(cbind(XpX, XpZ), 61 | cbind(ZpX, ZpZ + Ainv*alpha)) 62 | 63 | RHS = rbind(Xpy, 64 | Zpy) 65 | 66 | solutions = solve(LHS, RHS) 67 | 68 | round(solutions, 3) 69 | 70 | # Accuracy of evaluations 71 | 72 | CM = solve(LHS) 73 | 74 | diagCM = diag(CM[3:10, 3:10]) 75 | r_square = 1 - diagCM*alpha 76 | r = sqrt(r_square) 77 | SEP = sqrt(diagCM*varE) 78 | 79 | accuracy = round(data.frame(a, diagCM, r_square, r, SEP), 3) 80 | 81 | # Example 4.2 ------------------------------------------------------------- 82 | 83 | # Prepare pedigree 84 | a = seq(1, 8) 85 | s = c(NA, NA, NA, 1, 3, 1, 4, 3) 86 | d = c(NA, NA, NA, NA, 2, 2, 5, 6) 87 | ped = data.frame(a, s, d) 88 | 89 | pedsires = ped %>% 90 | filter(ped$a %in% ped$s) 91 | 92 | pedS = pedigree(label = pedsires$a, 93 | sire = pedsires$s, 94 | dam = pedsires$d) 95 | 96 | Asinv = getAInv(ped = pedS) 97 | 98 | # Variance components 99 | varS = 0.25 * 20 100 | varE = 60 - 5 101 | 102 | # Variance ratios 103 | alpha = varE/varS 104 | 105 | # Setting up the incidence matrices for the MME 106 | data$s = factor(x = data$s, levels = unique(pedX@sire)) 107 | Z = model.matrix( wwg ~ s - 1, data = data) 108 | 109 | XpX = crossprod(X) 110 | XpZ = crossprod(X, Z) 111 | ZpX = crossprod(Z, X) 112 | ZpZ = crossprod(Z) 113 | Xpy = crossprod(X, y) 114 | Zpy = crossprod(Z, y) 115 | 116 | LHS = rbind(cbind(XpX, XpZ), 117 | cbind(ZpX, ZpZ + Asinv*alpha)) 118 | 119 | RHS = rbind(Xpy, 120 | Zpy) 121 | 122 | solutions_sire = solve(LHS, RHS) 123 | 124 | round(solutions_sire, 3) 125 | 126 | -------------------------------------------------------------------------------- /Content/Chapter_04/Chapter_04_2.R: -------------------------------------------------------------------------------- 1 | # Chapter 4 2 | ## Reduced Animal Model 3 | 4 | # Clean the working environment 5 | rm(list = ls()) 6 | 7 | # Load packages 8 | library("pedigreemm") 9 | library("tidyverse") 10 | # install.packages("pedigreemm") 11 | # install.packages("tidyverse") 12 | 13 | 14 | # Example 4.3 ------------------------------------------------------------- 15 | 16 | # Prepare data 17 | wwg = c(4.5, 2.9, 3.9, 3.5, 5.0) 18 | sex = c("Male", "Female", "Female", "Male", "Male") 19 | an = seq(4, 8) 20 | sn = c(1, 3, 1, 4, 3) 21 | dn = c(NA, 2, 2, 5, 6) 22 | 23 | data = data.frame(an, sn, dn, sex, wwg) 24 | 25 | data$sex = as.factor(sex) 26 | data$sex = relevel(factor(sex), ref = "Male") 27 | data$an = factor(x = data$a, levels = seq(1, 8)) 28 | 29 | # Prepare pedigree 30 | a = seq(1, 6) 31 | s = c(NA, NA, NA, 1, 3, 1) 32 | d = c(NA, NA, NA, NA, 2, 2) 33 | ped = data.frame(a, s, d) 34 | 35 | pedX = pedigree(label = a, 36 | sire = s, 37 | dam = d) 38 | 39 | Ainv = getAInv(ped = pedX) 40 | 41 | # Variance components 42 | varA = 20 43 | varE = 40 44 | 45 | # Variance ratios 46 | alpha = varE/varA 47 | 48 | # Setting up the incidence matrices for the MME 49 | X = model.matrix(wwg ~ -1 + sex, data = data) 50 | 51 | W = matrix(0, nrow = nrow(data), ncol = nrow(Ainv)) 52 | 53 | rownames(W) = as.character(data$an) 54 | colnames(W) = as.character(pedX@label) 55 | 56 | for (i in 1:nrow(data)) { 57 | a_i = as.character(data[i, "an"]) 58 | if (a_i %in% colnames(W) ) { 59 | W[i, a_i] = 1 60 | } 61 | else { 62 | s_i = as.character(data[i, "sn"]) 63 | d_i = as.character(data[i, "dn"]) 64 | W[i, s_i] = 0.5 65 | W[i, d_i] = 0.5 66 | } 67 | } 68 | 69 | R = matrix(0, nrow = nrow(data), ncol = nrow(data)) 70 | 71 | rownames(R) = as.character(data$an) 72 | colnames(R) = as.character(data$an) 73 | 74 | for (i in 1:nrow(data)) { 75 | a_i = as.character(data[i, "an"]) 76 | if (a_i %in% unique(c(data$sn, data$dn)) ) { 77 | R[i, a_i] = varE 78 | } 79 | else { 80 | R[i, a_i] = varE + varA * 0.5 81 | } 82 | } 83 | 84 | Ri = solve(R) 85 | 86 | XpRiX = crossprod(X, Ri) %*% X 87 | XpRiW = crossprod(X, Ri) %*% W 88 | WpRiX = crossprod(W, Ri) %*% X 89 | WpRiW = crossprod(W, Ri) %*% W 90 | 91 | y = na.omit(data$wwg) 92 | XpRiy = crossprod(X, Ri) %*% y 93 | WpRiy = crossprod(W, Ri) %*% y 94 | 95 | LHS = rbind(cbind(XpRiX, XpRiW), 96 | cbind(WpRiX, WpRiW + Ainv*(1/varA) )) 97 | 98 | RHS = rbind(XpRiy, 99 | WpRiy) 100 | 101 | solutions = solve(LHS, RHS) 102 | 103 | round(solutions, 3) 104 | 105 | #Solutions for non-parents 106 | 107 | i = diag(2) 108 | d = diag(2, x = 0.5) 109 | k = solve(i+(solve(d))*alpha) 110 | 111 | W_n = W[4:5,] 112 | X_n = X[4:5,] 113 | y_n = y[4:5] 114 | 115 | b = solutions[1:2,] 116 | a_p = solutions[-(1:2),] 117 | 118 | a_n = W_n %*% a_p + k %*% (y_n - X_n %*% b - W_n %*% a_p) 119 | 120 | round(a_n, 3) 121 | 122 | -------------------------------------------------------------------------------- /Content/Chapter_04/Chapter_04_3.R: -------------------------------------------------------------------------------- 1 | # Chapter 4 2 | # Animal Model with Groups 3 | 4 | # Clean the working environment 5 | rm(list = ls()) 6 | 7 | # Load packages 8 | library("tidyverse") 9 | library("nadiv") 10 | # install.packages("tidyverse") 11 | # install.packages("nadiv") 12 | 13 | # Example 4.4 ------------------------------------------------------------- 14 | 15 | # Original pedigree 16 | a = seq(1, 8) 17 | s = c(NA, NA, NA, 1, 3, 1, 4, 3) 18 | d = c(NA, NA, NA, NA, 2, 2, 5, 6) 19 | ped = data.frame(a, s, d) 20 | 21 | # Extend the pedigree with unknown parent groups 22 | g1 = max(a) + 1 23 | g2 = g1 + 1 24 | 25 | pedEx = ped %>% 26 | dplyr::mutate(s = ifelse(is.na(s), g1, s)) %>% 27 | dplyr::mutate(d = ifelse(is.na(d), g2, d)) %>% 28 | add_row(a = g1, d = NA, s = NA, .before = 1) %>% 29 | add_row(a = g2, d = NA, s = NA, .before = 2) 30 | 31 | # Create Ainv 32 | Ainv = nadiv::makeAinv(pedEx, ggroups = 2)$Ainv 33 | 34 | Ann = Ainv[1:8, 1:8] 35 | Anp = Ainv[1:8, 9:10] 36 | Apn = Ainv[9:10, 1:8] 37 | App = Ainv[9:10, 9:10] 38 | 39 | # Prepare data 40 | calves = seq(4, 8) 41 | wwg = c(4.5, 2.9, 3.9, 3.5, 5.0) 42 | sex = c("Male", "Female", "Female", "Male", "Male" ) 43 | 44 | data = data.frame(calves, sex, wwg) 45 | 46 | data$sex = as.factor(sex) 47 | data$sex = relevel(factor(sex), ref = "Male") 48 | 49 | data$calves = factor(x = data$calves, levels = ped$a) 50 | 51 | # Variance components 52 | varA = 20 53 | varE = 40 54 | 55 | # Variance ratios 56 | alpha = varE/varA 57 | 58 | # Model: y = Xb + ZQg + Za + e 59 | # Q = TQ* 60 | 61 | X = model.matrix(wwg ~ -1 + sex, data = data) 62 | Z = model.matrix(wwg ~ calves - 1, data = data) 63 | 64 | XpX = crossprod(X) 65 | ZpZ = crossprod(Z) 66 | Xpy = crossprod(X, data$wwg) 67 | Zpy = crossprod(Z, data$wwg) 68 | XpZ = crossprod(X, Z) 69 | ZpX = crossprod(Z, X) 70 | 71 | LHS = rbind(cbind(XpX, XpZ, 0, 0), 72 | cbind(ZpX, ZpZ + (Ann * alpha), Anp * alpha), 73 | cbind(0, 0, Apn * alpha, App * alpha)) 74 | 75 | RHS = rbind(Xpy, 76 | Zpy, 77 | 0, 78 | 0) 79 | 80 | # Constraints 81 | LHS = LHS[,-c(11)] 82 | LHS = LHS[-c(11),] 83 | RHS = RHS[-c(11),] 84 | 85 | solutions_QP = solve(LHS, RHS) 86 | 87 | rownames(solutions_QP) = c("Males", "Females", 88 | "1", "2", "3", "4", "5", "6", "7", "8", "G10") 89 | 90 | round(solutions_QP, 3) 91 | 92 | # Without Q-P transformation 93 | Ainv = nadiv::makeAinv(ped)$Ainv 94 | 95 | Q = nadiv::ggcontrib(pedEx) 96 | 97 | X = model.matrix(wwg ~ -1 + sex, data = data) 98 | 99 | data$calves = factor(x = data$calves, levels = rownames(Ainv)) 100 | Z = model.matrix(wwg ~ calves - 1, data = data) 101 | 102 | XpX = crossprod(X) 103 | XpZ = crossprod(X, Z) 104 | XpZQ = XpZ %*% Q 105 | 106 | ZpX = crossprod(Z, X) 107 | ZpZ = crossprod(Z) 108 | ZpZQ = ZpZ %*% Q 109 | 110 | QpZpX = crossprod(Q, ZpX) 111 | QpZpZ = crossprod(Q, ZpZ) 112 | QpZpZQ = QpZpZ %*% Q 113 | 114 | Xpy = crossprod(X, data$wwg) 115 | Zpy = crossprod(Z, data$wwg) 116 | QpZpy = crossprod(Q, Zpy) 117 | 118 | LHS = rbind(cbind(XpX, XpZ, XpZQ), 119 | cbind(ZpX, ZpZ + (Ainv * alpha), ZpZQ), 120 | cbind(QpZpX, QpZpZ, QpZpZQ)) 121 | 122 | RHS = rbind(Xpy, 123 | Zpy, 124 | QpZpy) 125 | 126 | # Constraints 127 | LHS = LHS[,-c(11)] 128 | LHS = LHS[-c(11),] 129 | RHS = RHS[-c(11),] 130 | 131 | solutions = solve(LHS, RHS) 132 | rownames(solutions) = c("Males", "Females", 133 | "1", "2", "3", "4", "5", "6", "7", "8", "G10") 134 | 135 | round(solutions, 3) 136 | 137 | a_star = solutions[c(3:10)] + Q %*% c(0, solutions_QP[11]) 138 | 139 | round(a_star, 3) 140 | 141 | # Compare from QP absorbed 142 | cbind(round(solutions_QP[3:10], 3), round(a_star, 3)) 143 | 144 | # To calculate from the solutions obtained by animal model without groups 145 | XpX = crossprod(X) 146 | ZpZ = crossprod(Z) 147 | Xpy = crossprod(X, data$wwg) 148 | Zpy = crossprod(Z, data$wwg) 149 | XpZ = crossprod(X, Z) 150 | ZpX = crossprod(Z, X) 151 | 152 | LHS = rbind(cbind(XpX, XpZ), 153 | cbind(ZpX, ZpZ + (Ainv * alpha))) 154 | 155 | RHS = rbind(Xpy, 156 | Zpy) 157 | 158 | solutions_am = solve(LHS, RHS) 159 | 160 | round(solutions_am, 3) 161 | 162 | a_star_am = solutions_am[c(3:10)] + Q %*% c(0, solutions_QP[11]) 163 | 164 | round(a_star_am, 3) 165 | 166 | # Compare 167 | cbind(round(solutions_QP[3:10], 3), round(a_star, 3), round(a_star_am, 3)) 168 | 169 | -------------------------------------------------------------------------------- /Content/Chapter_05/Chapter_05_1.R: -------------------------------------------------------------------------------- 1 | # Chapter 5 2 | ## Repeatability Model 3 | 4 | # Clean the working environment 5 | rm(list = ls()) 6 | 7 | # Load packages 8 | library("pedigreemm") 9 | # install.packages("pedigreemm") 10 | 11 | # Example 5.1 ------------------------------------------------------------- 12 | 13 | # Prepare pedigree 14 | a = seq(1, 8) 15 | s = c(NA, NA, NA, 1, 3, 1, 3, 1) 16 | d = c(NA, NA, NA, 2, 2, 5, 4, 7) 17 | ped = data.frame(a, s, d) 18 | 19 | pedX = pedigree(label = a, 20 | sire = s, 21 | dam = d) 22 | 23 | Ainv = getAInv(ped = pedX) 24 | 25 | # Prepare data 26 | cow = rep(seq(4, 8), each = 2) 27 | fy = c(201, 280, 150, 200, 160, 190, 180, 250, 285, 300) 28 | hys = c(1, 3, 1, 4, 2, 3, 1, 3, 2, 4) 29 | pairity = rep(c(1,2), 5) 30 | 31 | data = data.frame(cow, pairity, hys, fy) 32 | 33 | data$pairity = as.factor(pairity) 34 | data$hys = as.factor(hys) 35 | data$hys = relevel(factor(hys), ref = "1") 36 | data$cow = factor(x = data$cow, levels = pedX@label) 37 | 38 | # Variances 39 | varA = 20 40 | varP = 12 41 | varE = 28 42 | varY = 60 43 | 44 | # Variance ratios 45 | alpha1 = varE / varA 46 | alpha2 = varE / varP 47 | rep = (varA + varP) / varY 48 | 49 | # Setting up the incidence matrices for the MME 50 | X = model.matrix(fy ~ -1 + pairity + hys, data = data) 51 | X = X[,-4] 52 | 53 | Z = model.matrix(fy ~ cow - 1, data = data) 54 | 55 | W = model.matrix(fy ~ droplevels(cow) - 1, data = data) 56 | 57 | XpX = crossprod(X) 58 | ZpZ = crossprod(Z) 59 | WpW = crossprod(W) 60 | 61 | Xpy = crossprod(X, data$fy) 62 | Zpy = crossprod(Z, data$fy) 63 | Wpy = crossprod(W, data$fy) 64 | 65 | XpZ = crossprod(X, Z) 66 | XpW = crossprod(X, W) 67 | 68 | ZpX = crossprod(Z, X) 69 | ZpW = crossprod(Z, W) 70 | 71 | WpX = crossprod(W, X) 72 | WpZ = crossprod(W, Z) 73 | 74 | LHS = rbind(cbind(XpX, XpZ, XpW), 75 | cbind(ZpX, ZpZ + (Ainv * alpha1), ZpW), 76 | cbind(WpX, WpZ, WpW + (diag(nrow = ncol(W)) * alpha2))) 77 | 78 | RHS = rbind(Xpy, 79 | Zpy, 80 | Wpy) 81 | 82 | solutions = solve(LHS, RHS) 83 | 84 | round(solutions, 3) 85 | 86 | -------------------------------------------------------------------------------- /Content/Chapter_05/Chapter_05_2.R: -------------------------------------------------------------------------------- 1 | # Chapter 5 2 | ## Model with Common Environmental Effects 3 | 4 | # Clean the working environment 5 | rm(list = ls()) 6 | 7 | # Load packages 8 | library("pedigreemm") 9 | # install.packages("pedigreemm") 10 | 11 | # Example 5.2 ------------------------------------------------------------- 12 | 13 | # Prepare pedigree 14 | a = seq(1, 15) 15 | s = c(NA, NA, NA, NA, NA, 1, 1, 1, 3, 3, 3, 3, 1, 1, 1) 16 | d = c(NA, NA, NA, NA, NA, 2, 2, 2, 4, 4, 4, 4, 5, 5, 5) 17 | ped = data.frame(a, s, d) 18 | 19 | pedX = pedigree(label = a, 20 | sire = s, 21 | dam = d) 22 | 23 | Ainv = getAInv(ped = pedX) 24 | 25 | # Prepare data 26 | piglet = seq(6, 15) 27 | ww = c(90, 70, 65, 98, 106, 60, 80, 100, 85, 68) 28 | sex = c("Male", "Female", "Female", "Female", "Male", "Female", "Female", "Male", "Female", "Male") 29 | fsfamily = c(1, 1, 1, 2, 2, 2, 2, 3, 3, 3) 30 | 31 | data = data.frame(piglet, fsfamily, sex, ww) 32 | 33 | data$sex = as.factor(sex) 34 | data$sex = relevel(factor(sex), ref = "Male") 35 | data$fsfamily = as.factor(fsfamily) 36 | data$piglet = factor(x = data$piglet, levels = pedX@label) 37 | 38 | # Variances 39 | varP = 100 40 | varA = 20 41 | varC = 15 42 | varE = 65 43 | varY = 100 44 | 45 | # Variance ratios 46 | 47 | alpha1 = varE / varA 48 | alpha2 = varE / varC 49 | 50 | rep = (varA + varP) / varY 51 | 52 | # Setting up the incidence matrices for the MME 53 | X = model.matrix(ww ~ -1 + sex, data = data) 54 | 55 | Z = model.matrix(ww ~ piglet - 1, data = data) 56 | 57 | W = model.matrix(ww ~ fsfamily - 1, data = data) 58 | 59 | XpX = crossprod(X) 60 | ZpZ = crossprod(Z) 61 | WpW = crossprod(W) 62 | 63 | Xpy = crossprod(X, data$ww) 64 | Zpy = crossprod(Z, data$ww) 65 | Wpy = crossprod(W, data$ww) 66 | 67 | XpZ = crossprod(X, Z) 68 | XpW = crossprod(X, W) 69 | 70 | ZpX = crossprod(Z, X) 71 | ZpW = crossprod(Z, W) 72 | 73 | WpX = crossprod(W, X) 74 | WpZ = crossprod(W, Z) 75 | 76 | LHS = rbind(cbind(XpX, XpZ, XpW), 77 | cbind(ZpX, ZpZ + (Ainv * alpha1), ZpW), 78 | cbind(WpX, WpZ, WpW + (diag(nrow = ncol(W)) * alpha2))) 79 | 80 | RHS = rbind(Xpy, 81 | Zpy, 82 | Wpy) 83 | 84 | solutions = solve(LHS, RHS) 85 | 86 | round(solutions, 3) 87 | 88 | -------------------------------------------------------------------------------- /Content/Chapter_06/Chapter_06.R: -------------------------------------------------------------------------------- 1 | # Chapter 6 2 | ## Equal Design Matrices and No Missing Records 3 | 4 | # Clean the working environment 5 | rm(list = ls()) 6 | 7 | # Load packages 8 | library("pedigreemm") 9 | # install.packages("pedigreemm") 10 | 11 | # Example 6.1 ------------------------------------------------------------- 12 | 13 | # Prepare data 14 | wwg = c(4.5, 2.9, 3.9, 3.5, 5.0) 15 | pwg = c(6.8, 5.0, 6.8, 6.0, 7.5) 16 | sex = c("Male", "Female", "Female", "Male", "Male" ) 17 | a = seq(4, 8) 18 | s = c(1, 3, 1, 4, 3) 19 | d = c(NA, 2, 2, 5, 6) 20 | 21 | data = data.frame(a, s, d, sex, wwg, pwg) 22 | data$sex = factor(data$sex) 23 | data$sex = relevel(factor(sex), ref = "Male") 24 | 25 | y2 = c(wwg, pwg) 26 | trait = c("WWG", "WWG", "WWG", "WWG", "WWG", "PWG", "PWG", "PWG", "PWG", "PWG") 27 | sex2 = c(sex, sex) 28 | data2 = data.frame(y2, trait, sex2) 29 | data2$sex2 = factor(data2$sex2) 30 | data2$sex2 = relevel(factor(sex2), ref = "Male") 31 | 32 | # Prepare pedigree 33 | a = seq(1, 8) 34 | s = c(NA, NA, NA, 1, 3, 1, 4, 3) 35 | d = c(NA, NA, NA, NA, 2, 2, 5, 6) 36 | 37 | ped = data.frame(a, s, d) 38 | 39 | pedX = pedigree(label = a, 40 | sire = s, 41 | dam = d) 42 | 43 | Ainv = getAInv(ped = pedX) 44 | 45 | # (Co)variances 46 | G_0 = matrix(c(20, 18, 18, 40), nrow = 2) 47 | R_0 = matrix(c(40, 11, 11, 30), nrow = 2) 48 | 49 | G_0inv = solve(G_0) 50 | R_0inv = solve(R_0) 51 | 52 | # Setting up the incidence matrices for the MME 53 | X = model.matrix(wwg ~ -1 + sex, data = data) 54 | 55 | I = diag(1, 2) 56 | IX = kronecker(I, X) 57 | 58 | data$a = factor(x = data$a, levels = pedX@label) 59 | 60 | Z = model.matrix(wwg ~ a - 1, data = data) 61 | 62 | IZ = kronecker(I, Z) 63 | 64 | XRX = crossprod(IX, kronecker(R_0inv, diag(1, 5))) %*% IX 65 | XRZ = crossprod(IX, kronecker(R_0inv, diag(1, 5))) %*% IZ 66 | 67 | ZRZ = crossprod(IZ, kronecker(R_0inv, diag(1, 5))) %*% IZ 68 | ZRX = crossprod(IZ, kronecker(R_0inv, diag(1, 5))) %*% IX 69 | 70 | XRy = crossprod(IX, kronecker(R_0inv, diag(1, 5))) %*% y2 71 | ZRy = crossprod(IZ, kronecker(R_0inv, diag(1, 5))) %*% y2 72 | 73 | AiGi = kronecker(G_0inv, Ainv) 74 | 75 | LHS = rbind(cbind(XRX, XRZ), 76 | cbind(ZRX, ZRZ + AiGi)) 77 | 78 | RHS = rbind(XRy, 79 | ZRy) 80 | 81 | solutions = solve(LHS, RHS) 82 | 83 | round(solutions, 3) 84 | 85 | -------------------------------------------------------------------------------- /Content/Chapter_08/Chapter_08.R: -------------------------------------------------------------------------------- 1 | # Chapter 8 2 | ## Animal Model for a Maternal Trait 3 | 4 | # Clean the working environment 5 | rm(list = ls()) 6 | 7 | # Load packages 8 | library("pedigreemm") 9 | # install.packages("pedigreemm") 10 | 11 | 12 | # Example 8.1 ------------------------------------------------------------- 13 | 14 | # Prepare pedigree 15 | a = seq(1, 14) 16 | s = c(NA, NA, NA, NA, 1, 3, 4, 3, 1, 3, 3, 8, 9, 3) 17 | d = c(NA, NA, NA, NA, 2, 2, 6, 5, 6, 2, 7, 7, 2, 6) 18 | ped = data.frame(a, s, d) 19 | 20 | pedX = pedigree(label = a, 21 | sire = s, 22 | dam = d) 23 | 24 | Ainv = getAInv(ped = pedX) 25 | 26 | # Prepare data 27 | calf = seq(5, 14) 28 | bw = c(35.0, 20.0, 25.0, 40.0, 42.0, 22.0, 35.0, 34.0, 20.0, 40.0) 29 | herds = c(1, 1, 1, 1, 2, 2, 2, 3, 3, 3) 30 | pen = c(1, 2, 2, 1, 1, 2, 2, 2, 1, 2) 31 | dam = c(2, 2, 6, 5, 6, 2, 7, 7, 2, 6) 32 | 33 | data = data.frame(calf, herds, pen, bw, dam) 34 | 35 | data$herds = as.factor(herds) 36 | data$herds = relevel(factor(herds), ref = "1") 37 | data$pen = as.factor(pen) 38 | data$calf = factor(x = data$calf, levels = pedX@label) 39 | data$dam = factor(x = data$dam, levels = pedX@label) 40 | 41 | # (Co)variances 42 | varGA = 150 43 | varMA = 90 44 | covMA = -40 45 | varP = 40 46 | varE = 350 47 | 48 | G = matrix(c(varGA, covMA, 49 | covMA, varMA), 50 | nrow = 2, byrow = TRUE) 51 | 52 | Ginv = solve(G) 53 | 54 | # Variance ratios 55 | alpha = Ginv * varE 56 | 57 | alpha4 = varE / varP 58 | 59 | # Setting up the incidence matrices for the MME 60 | X = model.matrix(bw ~ -1 + pen + herds, data = data) 61 | 62 | Z = model.matrix(bw ~ -1 + calf, data = data) 63 | 64 | W = model.matrix(bw ~ -1 + dam, data = data) 65 | 66 | S = model.matrix(bw ~ -1 + droplevels(dam), data = data) 67 | 68 | XpX = crossprod(X) 69 | ZpZ = crossprod(Z) 70 | WpW = crossprod(W) 71 | SpS = crossprod(S) 72 | 73 | Xpy = crossprod(X, data$bw) 74 | Zpy = crossprod(Z, data$bw) 75 | Wpy = crossprod(W, data$bw) 76 | Spy = crossprod(S, data$bw) 77 | 78 | XpZ = crossprod(X, Z) 79 | XpW = crossprod(X, W) 80 | XpS = crossprod(X, S) 81 | 82 | ZpX = crossprod(Z, X) 83 | ZpW = crossprod(Z, W) 84 | ZpS = crossprod(Z, S) 85 | 86 | WpX = crossprod(W, X) 87 | WpZ = crossprod(W, Z) 88 | WpS = crossprod(W, S) 89 | 90 | SpX = crossprod(S, X) 91 | SpZ = crossprod(S, Z) 92 | SpW = crossprod(S, W) 93 | 94 | LHS = rbind(cbind(XpX, XpZ, XpW, XpS), 95 | cbind(ZpX, ZpZ + (Ainv * alpha[1,1]), ZpW + (Ainv * alpha[1,2]), ZpS), 96 | cbind(WpX, WpZ + (Ainv * alpha[1,2]), WpW + (Ainv * alpha[2,2]), WpS), 97 | cbind(SpX, SpZ, SpW, SpS + diag(1, nrow = nrow(SpS), ncol = ncol(SpS)) * alpha4)) 98 | 99 | RHS = rbind(Xpy, 100 | Zpy, 101 | Wpy, 102 | Spy) 103 | 104 | solutions = solve(LHS, RHS) 105 | 106 | round(solutions, 3) 107 | 108 | -------------------------------------------------------------------------------- /Content/Chapter_09/Chapter_09_1.R: -------------------------------------------------------------------------------- 1 | # Chapter 9 2 | ## Animal Model with Social Interaction Effects 3 | 4 | # Clean the working environment 5 | rm(list = ls()) 6 | 7 | # Load packages 8 | library("pedigreemm") 9 | # install.packages("pedigreemm") 10 | 11 | # Example 9.1 ------------------------------------------------------------- 12 | 13 | # Prepare pedigree 14 | a = seq(1, 15) 15 | s = c(NA, NA, NA, NA, NA, NA, 1, 1, 2, 1, 2, 3, 2, 3, 3) 16 | d = c(NA, NA, NA, NA, NA, NA, 4, 4, 5, 4, 5, 6, 5, 6, 6) 17 | 18 | ped = data.frame(a, s, d) 19 | 20 | pedX = pedigree(label = a, 21 | sire = s, 22 | dam = d) 23 | 24 | Ainv = getAInv(ped = pedX) 25 | 26 | # Prepare data 27 | animal = seq(7, 15) 28 | gr = c(5.50, 9.80, 4.90, 8.23, 7.50, 10.0, 4.50, 8.40, 6.40) 29 | sex = c("Male", "Female", "Female", "Male", "Female", "Female", "Male", "Female", "Male") 30 | pen = c(1, 1, 1, 2, 2, 2, 3, 3, 3) 31 | litter = c(1, 1, 2, 1, 2, 3, 2, 3, 3) 32 | 33 | data = data.frame(animal, sex, pen, litter, gr) 34 | 35 | data$sex = as.factor(sex) 36 | data$sex = relevel(factor(sex), ref = "Male") 37 | data$pen = as.factor(pen) 38 | data$litter = as.factor(litter) 39 | data$animal = factor(x = data$animal, levels = pedX@label) 40 | 41 | # (Co)variances 42 | varGD = 25.70 43 | varGS = 3.60 44 | covGDS = 2.25 45 | varC = 12.5 46 | varED = 40.6 47 | varES = 10.0 48 | rho = 0.2 49 | 50 | varE = varED + (3-1)*varES 51 | 52 | varEstar = varE - (rho * varE) 53 | 54 | G = matrix(c(varGD, covGDS, 55 | covGDS, varGS), 56 | nrow = 2, byrow = TRUE) 57 | 58 | Ginv = solve(G) 59 | 60 | # Variance ratios 61 | alpha = Ginv * varEstar 62 | round(alpha, 4) 63 | 64 | alpha4 = varEstar / (rho * varE) 65 | 66 | alpha5 = varEstar / varC 67 | 68 | # Setting up the incidence matrices for the MME 69 | # Model: y = Xb + Z_Du_D +Z_Su_S + Vg + Wc +e 70 | 71 | X = model.matrix(gr ~ -1 + sex, data = data) 72 | 73 | Zd = model.matrix(gr ~ -1 + animal, data = data) 74 | 75 | Zs = model.matrix(animal ~ -1 + pen, data = data) 76 | Zs = Zs %*% t(Zs) 77 | diag(Zs) = 0 78 | Zsp = matrix(0, nrow = nrow(Zd), ncol = 6) 79 | Zs = cbind(Zsp, Zs) 80 | colnames(Zs) = seq(1, 15) 81 | 82 | V = model.matrix(gr ~ -1 + pen, data = data) 83 | 84 | W = model.matrix(gr ~ -1 + litter, data = data) 85 | 86 | XpX = crossprod(X) 87 | ZdpZd = crossprod(Zd) 88 | ZspZs = crossprod(Zs) 89 | VpV = crossprod(V) 90 | WpW = crossprod(W) 91 | 92 | Xpy = crossprod(X, data$gr) 93 | Zdpy = crossprod(Zd, data$gr) 94 | Zspy = crossprod(Zs, data$gr) 95 | Vpy = crossprod(V, data$gr) 96 | Wpy = crossprod(W, data$gr) 97 | 98 | XpZd = crossprod(X, Zd) 99 | XpZs = crossprod(X, Zs) 100 | XpV = crossprod(X, V) 101 | XpW = crossprod(X, W) 102 | 103 | ZdpX = crossprod(Zd, X) 104 | ZdpZs = crossprod(Zd, Zs) 105 | ZdpV = crossprod(Zd, V) 106 | ZdpW = crossprod(Zd, W) 107 | 108 | ZspX = crossprod(Zs, X) 109 | ZspZd = crossprod(Zs, Zd) 110 | ZspV = crossprod(Zs, V) 111 | ZspW = crossprod(Zs, W) 112 | 113 | VpX = crossprod(V, X) 114 | VpZd = crossprod(V, Zd) 115 | VpZs = crossprod(V, Zs) 116 | VpW = crossprod(V, W) 117 | 118 | WpX = crossprod(W, X) 119 | WpZd = crossprod(W, Zd) 120 | WpZs = crossprod(W, Zs) 121 | WpV = crossprod(W, V) 122 | 123 | LHS = rbind(cbind(XpX, XpZd, XpZs, XpV, XpW), 124 | cbind(ZdpX, ZdpZd + (Ainv * alpha[1,1]), ZdpZs + (Ainv * alpha[1,2]), ZdpV, ZdpW), 125 | cbind(ZspX, ZspZd + (Ainv * alpha[1,2]), ZspZs + (Ainv * alpha[2,2]), ZspV, ZspW), 126 | cbind(VpX, VpZd, VpZs, VpV + diag(1, nrow = nrow(VpV), ncol = ncol(VpV)) * alpha4, VpW), 127 | cbind(WpX, WpZd, WpZs, WpV, WpW + diag(1, nrow = nrow(WpW), ncol = ncol(WpW)) * alpha5)) 128 | 129 | # isSymmetric(LHS, check.attributes = FALSE) 130 | 131 | RHS = rbind(Xpy, 132 | Zdpy, 133 | Zspy, 134 | Vpy, 135 | Wpy) 136 | 137 | solutions = solve(LHS, RHS) 138 | 139 | round(solutions, 3) 140 | 141 | TBV = solutions[3:17] + (3-1)*solutions[18:32] 142 | 143 | round(TBV, 3) 144 | 145 | -------------------------------------------------------------------------------- /Content/Chapter_09/Chapter_09_2.R: -------------------------------------------------------------------------------- 1 | # Chapter 9 2 | ## Model with no associative effects 3 | 4 | # Clean the working environment 5 | rm(list = ls()) 6 | 7 | # Load packages 8 | library("pedigreemm") 9 | # install.packages("pedigreemm") 10 | 11 | # Example 9.1 Model with no associative effects --------------------------- 12 | 13 | # Prepare pedigree 14 | a = seq(1, 15) 15 | s = c(NA, NA, NA, NA, NA, NA, 1, 1, 2, 1, 2, 3, 2, 3, 3) 16 | d = c(NA, NA, NA, NA, NA, NA, 4, 4, 5, 4, 5, 6, 5, 6, 6) 17 | 18 | ped = data.frame(a, s, d) 19 | 20 | pedX = pedigree(label = a, 21 | sire = s, 22 | dam = d) 23 | 24 | Ainv = getAInv(ped = pedX) 25 | 26 | # Prepare data 27 | animal = seq(7, 15) 28 | gr = c(5.50, 9.80, 4.90, 8.23, 7.50, 10.0, 4.50, 8.40, 6.40) 29 | sex = c("Male", "Female", "Female", "Male", "Female", "Female", "Male", "Female", "Male") 30 | pen = c(1, 1, 1, 2, 2, 2, 3, 3, 3) 31 | litter = c(1, 1, 2, 1, 2, 3, 2, 3, 3) 32 | 33 | data = data.frame(animal, sex, pen, litter, gr) 34 | 35 | data$sex = as.factor(sex) 36 | data$sex = relevel(factor(sex), ref = "Male") 37 | data$pen = as.factor(pen) 38 | data$litter = as.factor(litter) 39 | data$animal = factor(x = data$animal, levels = pedX@label) 40 | 41 | # (Co)variances 42 | varGD = 25.70 43 | varC = 12.5 44 | varED = 40.6 45 | varES = 10.0 46 | 47 | varE = varED + (3-1)*varES 48 | 49 | # Variance ratios 50 | alpha1 = varE / varGD 51 | alpha2 = varE / varC 52 | 53 | 54 | # Setting up the incidence matrices for the MME 55 | 56 | X = model.matrix(gr ~ -1 + pen + sex, data = data) 57 | 58 | Zd = model.matrix(gr ~ -1 + animal, data = data) 59 | 60 | W = model.matrix(gr ~ -1 + litter, data = data) 61 | 62 | XpX = crossprod(X) 63 | ZdpZd = crossprod(Zd) 64 | WpW = crossprod(W) 65 | 66 | Xpy = crossprod(X, data$gr) 67 | Zdpy = crossprod(Zd, data$gr) 68 | Wpy = crossprod(W, data$gr) 69 | 70 | XpZd = crossprod(X, Zd) 71 | XpW = crossprod(X, W) 72 | 73 | ZdpX = crossprod(Zd, X) 74 | ZdpW = crossprod(Zd, W) 75 | 76 | WpX = crossprod(W, X) 77 | WpZd = crossprod(W, Zd) 78 | 79 | LHS = rbind(cbind(XpX, XpZd, XpW), 80 | cbind(ZdpX, ZdpZd + (Ainv * alpha1), ZdpW), 81 | cbind(WpX, WpZd, WpW + diag(1, nrow = nrow(WpW), ncol = ncol(WpW)) * alpha2)) 82 | 83 | RHS = rbind(Xpy, 84 | Zdpy, 85 | Wpy) 86 | 87 | solutions = solve(LHS, RHS) 88 | 89 | round(solutions, 3) 90 | 91 | -------------------------------------------------------------------------------- /Content/Chapter_10/Chapter_10.R: -------------------------------------------------------------------------------- 1 | # Chapter 10 2 | ## Fixed Regression Model 3 | ## Random Regression Model 4 | 5 | # Clean the working environment 6 | rm(list = ls()) 7 | 8 | # Load packages 9 | library("pedigreemm") 10 | library("tidyverse") 11 | library("orthopolynom") 12 | # install.packages("pedigreemm") 13 | # install.packages("tidyverse") 14 | # install.packages("orthopolynom") 15 | 16 | 17 | # Example 10.1 ------------------------------------------------------------- 18 | 19 | # Prepare the matrix of Legendre polynomials evaluated at different DIM 20 | # Appendix G 21 | 22 | dim = c(4, 38, 72, 106, 140, 174, 208, 242, 276, 310) 23 | 24 | dmin = min(dim) 25 | dmax = max(dim) 26 | adim = -1 + 2*(dim - dmin) / (dmax - dmin) 27 | 28 | k = 5 29 | 30 | M = matrix(0, nrow = length(dim), ncol = k) 31 | for (i in 1:k) { 32 | M[,i] = adim^(i-1) 33 | } 34 | 35 | legendre = legendre.polynomials((k-1), normalized = TRUE) 36 | 37 | Lambda = matrix(0, nrow = k, ncol = k) 38 | Lambda[1,1] = unlist(legendre[1]) 39 | Lambda[1:2,2] = unlist(legendre[2]) 40 | Lambda[1:3,3] = unlist(legendre[3]) 41 | Lambda[1:4,4] = unlist(legendre[4]) 42 | Lambda[1:5,5] = unlist(legendre[5]) 43 | 44 | Phi = M %*% Lambda 45 | 46 | # Prepare data 47 | htd = seq(1:10) 48 | 49 | tdy_4 = c(17.0, 18.6, 24.0, 20.0, 20.0, 15.6, 16.0, 13.0, 8.2, 8.0) 50 | tdy_5 = c(23.0, 21.0, 18.0, 17.0, 16.2, 14.0, 14.2, 13.4, 11.8, 11.4) 51 | tdy_6 = c(NA, NA, NA, NA, NA, 10.4, 12.3, 13.2, 11.6, 8.4) 52 | tdy_7 = c(NA, NA, NA, 22.8, 22.4, 21.4, 18.8, 18.3, 16.2, 15.0) 53 | tdy_8 = c(22.2, 20.0, 21.0, 23.0, 16.8, 11.0, 13.0, 17.0, 13.0, 12.6) 54 | 55 | data = data.frame(c(tdy_4, tdy_5, tdy_6, tdy_7, tdy_8), rep(1:10, 5), rep(4:8, each = 10)) 56 | 57 | colnames(data) = c("tdy", "htd", "animals") 58 | 59 | data$htd = as.factor(htd) 60 | data$htd = relevel(factor(htd), ref = "10") 61 | data$animals = factor(x = data$animals, levels = pedX@label) 62 | 63 | data = drop_na(data) 64 | 65 | colnames(Phi) = c("Leg0", "Leg1", "Leg2", "Leg3", "Leg4") 66 | 67 | data = cbind(data, rbind(Phi, Phi, Phi[1:5,], Phi[1:7,], Phi)) 68 | 69 | # Variances 70 | varA = 5.521 71 | varP = 8.470 72 | varE = 3.710 73 | 74 | # Variance ratios 75 | alpha1 = varE / varA 76 | alpha2 = varE / varP 77 | 78 | # Prepare pedigree 79 | a = seq(1, 8) 80 | s = c(NA, NA, NA, 1, 3, 1, 3, 1) 81 | d = c(NA, NA, NA, 2, 2, 5, 4, 7) 82 | ped = data.frame(a, s, d) 83 | 84 | pedX = pedigree(label = a, 85 | sire = s, 86 | dam = d) 87 | 88 | Ainv = getAInv(ped = pedX) 89 | 90 | # Setting up the incidence matrices for the MME 91 | X1 = model.matrix(tdy ~ -1 + htd, data = data) 92 | X1pX1 = crossprod(X1) 93 | 94 | X2 = rbind(Phi, Phi, Phi[1:5,], Phi[1:7,], Phi) 95 | X2pX2 = crossprod(X2) 96 | 97 | Q = model.matrix(tdy ~ -1 + animals, data = data) 98 | 99 | Z = model.matrix(tdy ~ -1 + droplevels(animals), data = data) 100 | 101 | QpQ = crossprod(Q) 102 | ZpZ = crossprod(Z) 103 | 104 | y = drop_na(data) 105 | 106 | X1py = crossprod(X1, data$tdy) 107 | X2py = crossprod(X2, data$tdy) 108 | Qpy = crossprod(Q, data$tdy) 109 | Zpy = crossprod(Z, data$tdy) 110 | 111 | X1pX2 = crossprod(X1, X2) 112 | X1pQ = crossprod(X1, Q) 113 | X1pZ = crossprod(X1, Z) 114 | 115 | X2pX1 = crossprod(X2, X1) 116 | X2pQ = crossprod(X2, Q) 117 | X2pZ = crossprod(X2, Z) 118 | 119 | QpX1 = crossprod(Q, X1) 120 | QpX2 = crossprod(Q, X2) 121 | QpZ = crossprod(Q, Z) 122 | 123 | ZpX1 = crossprod(Z, X1) 124 | ZpX2 = crossprod(Z, X2) 125 | ZpQ = crossprod(Z, Q) 126 | 127 | LHS = rbind(cbind(X1pX1, X1pX2, X1pQ, X1pZ), 128 | cbind(X2pX1, X2pX2, X2pQ, X2pZ), 129 | cbind(QpX1, QpX2, QpQ + (Ainv * alpha1), QpZ), 130 | cbind(ZpX1, ZpX2, ZpQ, ZpZ + diag(1, nrow = nrow(ZpZ), ncol = ncol(ZpZ)) * alpha2)) 131 | 132 | RHS = rbind(X1py, 133 | X2py, 134 | Qpy, 135 | Zpy) 136 | 137 | # Constraints 138 | LHS = LHS[,-c(1)] 139 | LHS = LHS[-c(1),] 140 | RHS = RHS[-c(1),] 141 | 142 | solutions = solve(LHS, RHS) 143 | 144 | round(solutions, 4) 145 | 146 | # Example 10.2 ------------------------------------------------------------- 147 | 148 | # Covariance matrices for the random regression coefficients for animal effect and pe effects 149 | G = matrix(c(3.297, 0.594, -1.381, 150 | 0.594, 0.921, -0.289, 151 | -1.381, -0.289, 1.005), 152 | nrow = 3, byrow = TRUE) 153 | 154 | P = matrix(c(6.872, -0.254, -1.101, 155 | -0.254, 3.171, 0.167, 156 | -1.101, 0.167, 2.457), 157 | nrow = 3, byrow = TRUE) 158 | 159 | Ginv = solve(G) 160 | Pinv = solve(P) 161 | 162 | t(Phi[4,1:3]) %*% G %*% Phi[4,1:3] 163 | 164 | t(Phi[4,1:3]) %*% G %*% Phi[5,1:3] 165 | 166 | # Setting up the incidence matrices for the MME 167 | X1 = model.matrix(tdy ~ htd, data = data) 168 | 169 | X1RX1 = t(X1) %*% diag(1/varE, nrow(data)) %*% X1 170 | 171 | X2 = rbind(Phi, Phi, Phi[1:5,], Phi[1:7,], Phi) 172 | 173 | X2RX2 = t(X2) %*% diag(1/varE, nrow(data)) %*% X2 174 | 175 | Qp = matrix(0, nrow = 42, ncol = 15) 176 | Qp[1:10, 1:3] = Phi[ ,1:3] 177 | Qp[11:20, 4:6] = Phi[ ,1:3] 178 | Qp[21:25, 7:9] = Phi[1:5,1:3] 179 | Qp[26:32, 10:12] = Phi[1:7,1:3] 180 | Qp[33:42, 13:15] = Phi[ ,1:3] 181 | 182 | # For animal 6, Q6' is 183 | t(Phi[1:5,1:3]) 184 | 185 | t(Qp[21:25, 7:9]) 186 | 187 | QpRQp = t(Qp) %*% diag(1/varE, nrow(data)) %*% Qp 188 | 189 | Z = Qp 190 | ZRZ = QpRQp 191 | 192 | # Add nr rows and columns for 3 animals without records and 3 regressions 3*3 193 | 194 | QRQ = rbind(matrix(0, nrow = 3*3, ncol = 8*3), 195 | cbind(matrix(0, nrow = nrow(QpRQp), ncol = 3*3), QpRQp) ) 196 | 197 | Q = cbind(matrix(0, ncol = 3*3, nrow = nrow(data)), Qp) 198 | 199 | X1Ry = t(X1) %*% diag(1/varE, nrow(data)) %*% data$tdy 200 | X2Ry = t(X2) %*% diag(1/varE, nrow(data)) %*% data$tdy 201 | QRy = t(Q) %*% diag(1/varE, nrow(data)) %*% data$tdy 202 | ZRy = t(Z) %*% diag(1/varE, nrow(data)) %*% data$tdy 203 | 204 | X1RX2 = t(X1) %*% diag(1/varE, nrow(data)) %*% X2 205 | X1RQ = t(X1) %*% diag(1/varE, nrow(data)) %*% Q 206 | X1RZ = t(X1) %*% diag(1/varE, nrow(data)) %*% Z 207 | 208 | X2RX1 = t(X2) %*% diag(1/varE, nrow(data)) %*% X1 209 | X2RQ = t(X2) %*% diag(1/varE, nrow(data)) %*% Q 210 | X2RZ = t(X2) %*% diag(1/varE, nrow(data)) %*% Z 211 | 212 | QRX1 = t(Q) %*% diag(1/varE, nrow(data)) %*% X1 213 | QRX2 = t(Q) %*% diag(1/varE, nrow(data)) %*% X2 214 | QRZ = t(Q) %*% diag(1/varE, nrow(data)) %*% Z 215 | 216 | ZRX1 = t(Z) %*% diag(1/varE, nrow(data)) %*% X1 217 | ZRX2 = t(Z) %*% diag(1/varE, nrow(data)) %*% X2 218 | ZRQ = t(Z) %*% diag(1/varE, nrow(data)) %*% Q 219 | 220 | LHS = rbind(cbind(X1RX1, X1RX2, X1RQ, X1RZ), 221 | cbind(X2RX1, X2RX2, X2RQ, X2RZ), 222 | cbind(QRX1, QRX2, QRQ + kronecker(Ainv, Ginv), QRZ), 223 | cbind(ZRX1, ZRX2, ZRQ, ZRZ + kronecker(diag(1, 5),Pinv)) ) 224 | 225 | RHS = rbind(X1Ry, 226 | X2Ry, 227 | QRy, 228 | ZRy) 229 | 230 | # Constraints 231 | LHS = LHS[,-c(1)] 232 | LHS = LHS[-c(1),] 233 | RHS = RHS[-c(1),] 234 | 235 | solutions = solve(LHS, RHS) 236 | 237 | round(solutions, 4) 238 | 239 | -------------------------------------------------------------------------------- /Content/Chapter_11/Chapter_11_1.R: -------------------------------------------------------------------------------- 1 | # Chapter 11 2 | ## SNP-BLUP 3 | ## GBLUP 4 | ## Computing SNP solutions from GBLUP 5 | ## Computing base population allele frequencies 6 | 7 | # Clean the working environment 8 | rm(list = ls()) 9 | 10 | # Load packages 11 | library("pedigreemm") 12 | # install.packages("pedigreemm") 13 | 14 | # Example 11.2 ------------------------------------------------------------ 15 | 16 | # Prepare data 17 | a = seq(13, 26) 18 | s = c(NA, NA, 13, 15, 15, 14, 14, 14, 1, 14, 14, 14, 14, 14) 19 | d = c(NA, NA, 4, 2, 5, 6, 9, 9, 3, 8, 11, 10, 7, 12) 20 | dyd = c(9.0, 13.4, 12.7, 15.4, 5.9, 7.7, 10.2, 4.8, NA, NA, NA, NA, NA, NA) 21 | # Animals 13 to 20 are assumed as the reference population 22 | # Animals 21 to 26 are assumed as the selection candidates 23 | data = data.frame(a, s, d, dyd) 24 | 25 | data$a = factor(x = data$a, levels = data$a) 26 | 27 | # Genotypes 28 | g13 = c(2, 0, 1, 1, 0, 0, 0, 2, 1, 2) 29 | g14 = c(1, 0, 0, 0, 0, 2, 0, 2, 1, 0) 30 | g15 = c(1, 1, 2, 1, 1, 0, 0, 2, 1, 2) 31 | g16 = c(0, 0, 2, 1, 0, 1, 0, 2, 2, 1) 32 | g17 = c(0, 1, 1, 2, 0, 0, 0, 2, 1, 2) 33 | g18 = c(1, 1, 0, 1, 0, 2, 0, 2, 2, 1) 34 | g19 = c(0, 0, 1, 1, 0, 2, 0, 2, 2, 0) 35 | g20 = c(0, 1, 1, 0, 0, 1, 0, 2, 2, 0) 36 | g21 = c(2, 0, 0, 0, 0, 1, 2, 2, 1, 2) 37 | g22 = c(0, 0, 0, 1, 1, 2, 0, 2, 0, 0) 38 | g23 = c(0, 1, 1, 0, 0, 1, 0, 2, 2, 1) 39 | g24 = c(1, 0, 0, 0, 1, 1, 0, 2, 0, 0) 40 | g25 = c(0, 0, 0, 1, 1, 2, 0, 2, 1, 0) 41 | g26 = c(1, 0, 1, 1, 0, 2, 0, 1, 0, 0) 42 | 43 | geno = rbind(g13, g14, g15, g16, g17, g18, g19, g20, g21, g22, g23, g24, g25, g26) 44 | 45 | rownames(geno) = seq(13, 26) 46 | 47 | geno_ref = geno[c(1:8),] 48 | 49 | geno_cand = geno[c(9:14),] 50 | 51 | pm = colMeans(geno) / 2 52 | round(pm, 3) 53 | 54 | # Variance ratios 55 | varA = 35.241 56 | varE = 245 57 | k = 2 * (sum(pm * (1 - pm))) 58 | alpha = k*(varE / varA) 59 | 60 | Z1 = sweep(geno_ref,2,2*pm,"-") 61 | 62 | # Setting up the incidence matrices for the MME 63 | y = na.omit(data$dyd) 64 | X = matrix(rep(1, length(y))) 65 | 66 | XpX = crossprod(X) 67 | ZpZ = crossprod(Z1) 68 | 69 | Xpy = crossprod(X, y) 70 | Zpy = crossprod(Z1, y) 71 | 72 | XpZ = crossprod(X, Z1) 73 | ZpX = crossprod(Z1, X) 74 | 75 | LHS = rbind(cbind(XpX, XpZ), 76 | cbind(ZpX, ZpZ + (diag(nrow = ncol(Z1)) * alpha))) 77 | 78 | RHS = rbind(Xpy, 79 | Zpy) 80 | 81 | sol_SNPBLUP = solve(LHS, RHS) 82 | 83 | # SNP effects 84 | round(sol_SNPBLUP, 3) 85 | 86 | # Compute DGV for the reference population 87 | round(Z1%*%sol_SNPBLUP[-1], 3) 88 | 89 | # Compute DGV for the selection candidates 90 | Z2 = sweep(geno_cand,2,2*pm,"-") 91 | 92 | round(Z2%*%sol_SNPBLUP[-1], 3) 93 | 94 | # Re-analyse using EDCs as weights 95 | edc = c(558, 722, 300, 73, 52, 87, 64, 103) 96 | 97 | dii = (1/edc) 98 | D = diag(x=dii) 99 | 100 | Dinv = diag(x=edc) 101 | 102 | XpX = t(X)%*%(Dinv)%*%X 103 | ZpZ = t(Z1)%*%(Dinv)%*%Z1 104 | 105 | Xpy = t(X)%*%(Dinv)%*%y 106 | Zpy = t(Z1)%*%(Dinv)%*%y 107 | 108 | XpZ = t(X)%*%(Dinv)%*%Z1 109 | ZpX = t(Z1)%*%(Dinv)%*%X 110 | 111 | LHS = rbind(cbind(XpX, XpZ), 112 | cbind(ZpX, ZpZ + (diag(nrow = ncol(Z1)) * alpha))) 113 | 114 | RHS = rbind(Xpy, 115 | Zpy) 116 | 117 | sol_SNPBLUPwt = solve(LHS, RHS) 118 | 119 | round(sol_SNPBLUPwt, 3) 120 | 121 | # Compute DGV for the reference population 122 | round(Z1%*%sol_SNPBLUPwt[-1], 3) 123 | 124 | # Compute DGV for the selection candidates 125 | Z2 = sweep(geno_cand,2,2*pm,"-") 126 | 127 | round(Z2%*%sol_SNPBLUPwt[-1], 3) 128 | 129 | # Example 11.3 ------------------------------------------------------------ 130 | 131 | # Prepare genomic relationship matrix G 132 | M = as.matrix(geno) 133 | p = colMeans(M)/2 134 | q = 1-p 135 | 136 | Za = sweep(M,2,2*p,"-") 137 | 138 | G = tcrossprod(Za) / (2 * (sum(p * q))) 139 | round(G, 3) 140 | 141 | # Make matrix invertible 142 | fG = G + (diag(0.01, nrow(G))) 143 | Ginv = solve(fG) 144 | 145 | # Setting up the incidence matrices for the MME 146 | X = model.matrix(dyd ~ 1, data = data) 147 | 148 | Z = model.matrix(dyd ~ -1 + a, data = data) 149 | 150 | # Variance ratios 151 | alpha = 245/35.241 152 | 153 | y = na.omit(data$dyd) 154 | 155 | XpX = crossprod(X) 156 | XpZ = crossprod(X, Z) 157 | 158 | ZpX = crossprod(Z, X) 159 | ZpZ = crossprod(Z) 160 | 161 | Xpy = crossprod(X, y) 162 | Zpy = crossprod(Z, y) 163 | 164 | LHS = rbind(cbind(XpX, XpZ), 165 | cbind(ZpX, ZpZ + Ginv*alpha)) 166 | 167 | RHS = rbind(Xpy, 168 | Zpy) 169 | 170 | solutions_GBLUP = solve(LHS, RHS) 171 | 172 | round(solutions_GBLUP, 3) 173 | 174 | # Example 11.4 ------------------------------------------------------------ 175 | 176 | a_hat = solutions_GBLUP[-1] 177 | # To get exactly the same g as in the book, use a_hat from the book (rounded values) 178 | # a_hat = matrix(c(0.069, 0.116, 0.049, 0.260, -0.500, -0.359, 0.146, 179 | # -0.231, 0.028, 0.115, -0.240, 0.143, 0.054, 0.353)) 180 | 181 | k = 2 * (sum(p * q)) 182 | 183 | g = 1/k * t(Za) %*% Ginv %*% a_hat 184 | 185 | round(g, 3) 186 | 187 | # Example 11.6 ------------------------------------------------------------ 188 | 189 | # Prepare pedigree 190 | a_full = seq(1, 26) 191 | s_full = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 13, 15, 15, 14, 14, 14, 1, 14, 14, 14, 14, 14) 192 | d_full = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 4, 2, 5, 6, 9, 9, 3, 8, 11, 10, 7, 12) 193 | 194 | pedX = pedigree(label = a_full, 195 | sire = s_full, 196 | dam = d_full) 197 | 198 | Ainv = getAInv(ped = pedX) 199 | 200 | # Setting up the incidence matrices for the MME 201 | 202 | # Vector of gene content for SNP #1 203 | y = geno[,1] 204 | 205 | X = model.matrix(y ~ 1) 206 | 207 | aid = factor(x = seq(13, 26), levels = Ainv@Dimnames[[1]]) 208 | 209 | M = model.matrix(y ~ -1 + aid) 210 | 211 | eta = 0.01 212 | 213 | XpX = crossprod(X) 214 | XpM = crossprod(X, M) 215 | MpX = crossprod(M, X) 216 | MpM = crossprod(M) 217 | Xpy = crossprod(X, y) 218 | Mpy = crossprod(M, y) 219 | 220 | LHS = rbind(cbind(XpX, XpM), 221 | cbind(MpX, MpM + Ainv*eta)) 222 | 223 | RHS = rbind(Xpy, 224 | Mpy) 225 | 226 | solutions = solve(LHS, RHS) 227 | 228 | round(solutions, 3) 229 | 230 | round(solutions[2:27] + solutions[1], 3) 231 | 232 | round(solutions[2:27] + solutions[1]) 233 | 234 | -------------------------------------------------------------------------------- /Content/Chapter_11/Chapter_11_2.R: -------------------------------------------------------------------------------- 1 | # Chapter 11 2 | ## Haplotype models 3 | 4 | # Clean the working environment 5 | rm(list = ls()) 6 | 7 | # Example 11.8 ------------------------------------------------------------ 8 | 9 | # Prepare data 10 | wwg = c(4.5, 2.9, 3.9, 3.5, 5.0) 11 | sex = c("Male", "Female", "Female", "Male", "Male" ) 12 | a = seq(4, 8) 13 | s = c(1, 3, 1, 4, 3) 14 | d = c(NA, 2, 2, 5, 6) 15 | 16 | data = data.frame(a, s, d, sex, wwg) 17 | 18 | data$a = factor(x = data$a, levels = data$a) 19 | 20 | y = data$wwg 21 | 22 | # Genotypes 23 | g1 = c(2, 0, 1, 0, 1, 0, 2, 2, 0) 24 | g2 = c(0, 2, 1, 1, 1, 1, 0, 2, 1) 25 | g3 = c(2, 1, 1, 0, 1, 2, 0, 0, 1) 26 | g4 = c(1, 1, 1, 1, 1, 1, 1, 2, 0) 27 | g5 = c(1, 0, 0, 0, 0, 1, 0, 1, 2) 28 | 29 | geno = rbind(g1, g2, g3, g4, g5) 30 | 31 | rownames(geno) = seq(1, 5) 32 | 33 | # Prepare genomic relationship matrix G 34 | M = as.matrix(geno) 35 | p = colMeans(M)/2 36 | q = 1-p 37 | 38 | Za = sweep(M,2,2*p,"-") 39 | 40 | G = tcrossprod(Za) / (2 * (sum(p * q))) 41 | round(G, 3) 42 | 43 | # Make matrix invertible 44 | fG = G + (diag(0.01, nrow(G))) 45 | Ginv = solve(fG) 46 | 47 | # Setting up the incidence matrices for the MME 48 | X = model.matrix(wwg ~ 1, data = data) 49 | 50 | Z = model.matrix(wwg~ -1 + a, data = data) 51 | 52 | # Variance ratios 53 | alpha = 40/20 54 | 55 | XpX = crossprod(X) 56 | XpZ = crossprod(X, Z) 57 | 58 | ZpX = crossprod(Z, X) 59 | ZpZ = crossprod(Z) 60 | 61 | Xpy = crossprod(X, y) 62 | Zpy = crossprod(Z, y) 63 | 64 | LHS = rbind(cbind(XpX, XpZ), 65 | cbind(ZpX, ZpZ + Ginv*alpha)) 66 | 67 | RHS = rbind(Xpy, 68 | Zpy) 69 | 70 | solutions_GBLUP = solve(LHS, RHS) 71 | 72 | round(solutions_GBLUP, 3) 73 | 74 | # Pseudo-SNPs 75 | h1 = c(1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 2, 0, 0, 0, 0) 76 | h2 = c(0, 0, 1, 1, 0, 0, 0, 1, 1, 0, 0, 0, 1, 1, 0, 0) 77 | h3 = c(0, 1, 0, 0, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 1, 1) 78 | h4 = c(0, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1, 0, 0, 0) 79 | h5 = c(0, 1, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 1, 1, 0) 80 | 81 | hap = rbind(h1, h2, h3, h4, h5) 82 | 83 | rownames(hap) = seq(1, 5) 84 | 85 | # Prepare haplotype-based genomic relationship matrix G 86 | M = as.matrix(hap) 87 | p = colMeans(M)/2 88 | q = 1-p 89 | 90 | Za = sweep(M,2,2*p,"-") 91 | 92 | Ghap = tcrossprod(Za) / (2 * (sum(p * q))) 93 | round(Ghap, 3) 94 | 95 | # Make matrix invertible 96 | fGhap = Ghap + (diag(0.01, nrow(Ghap))) 97 | Ginvhap = solve(fGhap) 98 | 99 | # Setting up the incidence matrices for the MME 100 | rm(LHS, RHS) 101 | 102 | LHS = rbind(cbind(XpX, XpZ), 103 | cbind(ZpX, ZpZ + Ginvhap*alpha)) 104 | 105 | RHS = rbind(Xpy, 106 | Zpy) 107 | 108 | solutions_hap = solve(LHS, RHS) 109 | 110 | round(solutions_hap, 3) 111 | 112 | round(cor(solutions_hap, solutions_GBLUP), 3) 113 | 114 | -------------------------------------------------------------------------------- /Content/Chapter_11/Chapter_11_3.R: -------------------------------------------------------------------------------- 1 | # Chapter 11 2 | ## Multivariate genomic models 3 | 4 | # Clean the working environment 5 | rm(list = ls()) 6 | 7 | # Example 11.13 ----------------------------------------------------------- 8 | 9 | # Genotypes 10 | g4 = c(0, 2, 1, 1, 1, 2, 0, 1, 1, 1) 11 | g5 = c(2, 1, 2, 1, 1, 0, 1, 0, 2, 0) 12 | g6 = c(1, 2, 1, 0, 0, 1, 1, 1, 2, 0) 13 | g7 = c(1, 2, 2, 1, 0, 1, 1, 1, 2, 1) 14 | g8 = c(1, 1, 1, 1, 1, 0, 1, 1, 2, 0) 15 | 16 | geno = rbind(g4, g5, g6, g7, g8) 17 | 18 | # Prepare data 19 | wwg = c(4.5, 2.9, 3.9, 3.5, 5.0) 20 | pwg = c(6.8, 5.0, 6.8, 6.0, 7.5) 21 | sex = c("Male", "Female", "Female", "Male", "Male" ) 22 | a = seq(4, 8) 23 | s = c(1, 3, 1, 4, 3) 24 | d = c(NA, 2, 2, 5, 6) 25 | 26 | data = data.frame(a, s, d, sex, wwg, pwg) 27 | data$sex = factor(data$sex) 28 | data$sex = relevel(factor(sex), ref = "Male") 29 | 30 | y2 = c(wwg, pwg) 31 | trait = c("WWG", "WWG", "WWG", "WWG", "WWG", "PWG", "PWG", "PWG", "PWG", "PWG") 32 | sex2 = c(sex, sex) 33 | data2 = data.frame(y2, trait, sex2) 34 | data2$sex2 = factor(data2$sex2) 35 | data2$sex2 = relevel(factor(sex2), ref = "Male") 36 | 37 | # (Co)variances 38 | G_0 = matrix(c(20, 18, 18, 40), nrow = 2) 39 | R_0 = matrix(c(40, 11, 11, 30), nrow = 2) 40 | 41 | G_0inv = solve(G_0) 42 | R_0inv = solve(R_0) 43 | 44 | # Prepare genomic relationship matrix G 45 | M = as.matrix(geno) 46 | p = colMeans(M)/2 47 | q = 1-p 48 | 49 | Za = sweep(M,2,2*p,"-") 50 | 51 | G = tcrossprod(Za) / (2 * (sum(p * q))) 52 | round(G, 3) 53 | 54 | # Make matrix invertible 55 | fG = G + (diag(0.01, nrow(G))) 56 | Ginv = solve(fG) 57 | 58 | # Setting up the incidence matrices for the MME 59 | X = model.matrix(wwg ~ -1 + sex, data = data) 60 | 61 | I = diag(1, 2) 62 | IX = kronecker(I, X) 63 | 64 | data$a = factor(x = data$a, levels = data$a) 65 | 66 | Z = model.matrix(wwg ~ -1 + a, data = data) 67 | 68 | IZ = kronecker(I, Z) 69 | 70 | XRX = crossprod(IX, kronecker(R_0inv, diag(1, 5))) %*% IX 71 | XRZ = crossprod(IX, kronecker(R_0inv, diag(1, 5))) %*% IZ 72 | 73 | ZRZ = crossprod(IZ, kronecker(R_0inv, diag(1, 5))) %*% IZ 74 | ZRX = crossprod(IZ, kronecker(R_0inv, diag(1, 5))) %*% IX 75 | 76 | XRy = crossprod(IX, kronecker(R_0inv, diag(1, 5))) %*% y2 77 | ZRy = crossprod(IZ, kronecker(R_0inv, diag(1, 5))) %*% y2 78 | 79 | AiGi = kronecker(G_0inv, Ginv) 80 | 81 | LHS = rbind(cbind(XRX, XRZ), 82 | cbind(ZRX, ZRZ + AiGi)) 83 | 84 | RHS = rbind(XRy, 85 | ZRy) 86 | 87 | solutions = solve(LHS, RHS) 88 | 89 | round(solutions, 3) 90 | 91 | -------------------------------------------------------------------------------- /Content/Chapter_12/APY_fja.R: -------------------------------------------------------------------------------- 1 | # APY Function 2 | 3 | APY_inverse = function(GRM, corelist) { 4 | # Index core and non-core 5 | core = corelist$core_status == 1 6 | noncore = corelist$core_status == 0 7 | 8 | ncore = sum(core) 9 | nnoncore = sum(noncore) 10 | 11 | # Partition G to core and non-core 12 | Gcc = GRM[core, core] 13 | Gcn = GRM[core, noncore] 14 | Gnc = GRM[noncore, core] 15 | Gnn = GRM[noncore, noncore] 16 | 17 | # Gpart = rbind(cbind(Gcc, Gcn), cbind(Gnc, Gnn)) 18 | 19 | # APY inverse based on above Gpart: 20 | Gcc_inv = solve(Gcc) 21 | 22 | Mnn_inv = matrix(data = 0, nrow = nnoncore, ncol = nnoncore) 23 | for(i in 1:nnoncore) 24 | { 25 | Mnn_inv[i,i] = 1 / (Gnn[i,i] - Gnc[i,] %*% Gcc_inv %*% Gcn[,i]) 26 | } 27 | 28 | APY11 = Gcc_inv + Gcc_inv %*% Gcn %*% Mnn_inv %*% Gnc %*% Gcc_inv 29 | APY12 = -1 * Gcc_inv %*% Gcn %*% Mnn_inv 30 | APY21 = -1 * Mnn_inv %*% Gnc %*% Gcc_inv 31 | # APY21 = t(APY12) 32 | APY22 = Mnn_inv 33 | 34 | Ginv_APY = rbind(cbind(APY11, APY12), 35 | cbind(APY21, APY22)) 36 | 37 | # Create index of ID's 38 | # Note - order is not the same as in the original G 39 | apy_ref = tibble(geno_id = c(rownames(Gcc), rownames(Gnn)), apy_order = seq(1:nrow(Ginv_APY))) 40 | orig_ref = full_join(corelist, apy_ref, by = "geno_id") 41 | 42 | list(APY_Ginv = Ginv_APY, index_file = orig_ref) 43 | } 44 | 45 | -------------------------------------------------------------------------------- /Content/Chapter_12/Chapter_12_1.R: -------------------------------------------------------------------------------- 1 | # Chapter 12 2 | ## SS-GBLUP 3 | 4 | # Clean the working environment 5 | rm(list = ls()) 6 | 7 | # Load packages 8 | library("tidyverse") 9 | library("pedigreemm") 10 | # install.packages("tidyverse") 11 | # install.packages("pedigreemm") 12 | 13 | # Example 12.1 ------------------------------------------------------------ 14 | 15 | # Prepare pedigree and data 16 | a = seq(1, 26) 17 | s = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 13, 15, 15, 14, 14, 14, 1, 14, 14, 14, 14, 14) 18 | d = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 4, 2, 5, 6, 9, 9, 3, 8, 11, 10, 7, 12) 19 | dyd = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 9.0, 13.4, 12.7, 15.4, 5.9, 7.7, 10.2, 4.8, NA, NA, NA, NA, NA, NA) 20 | 21 | data = data.frame(a, s, d, dyd) 22 | 23 | pedX = pedigree(label = data$a, 24 | sire = data$s, 25 | dam = data$d) 26 | 27 | A = getA(ped = pedX) 28 | 29 | Ainv = getAInv(ped = pedX) 30 | 31 | # Genotypes 32 | g13 = c(2, 0, 1, 1, 0, 0, 0, 2, 1, 2) 33 | g14 = c(1, 0, 0, 0, 0, 2, 0, 2, 1, 0) 34 | g15 = c(1, 1, 2, 1, 1, 0, 0, 2, 1, 2) 35 | g16 = c(0, 0, 2, 1, 0, 1, 0, 2, 2, 1) 36 | g17 = c(0, 1, 1, 2, 0, 0, 0, 2, 1, 2) 37 | g18 = c(1, 1, 0, 1, 0, 2, 0, 2, 2, 1) 38 | g19 = c(0, 0, 1, 1, 0, 2, 0, 2, 2, 0) 39 | g20 = c(0, 1, 1, 0, 0, 1, 0, 2, 2, 0) 40 | g21 = c(2, 0, 0, 0, 0, 1, 2, 2, 1, 2) 41 | g22 = c(0, 0, 0, 1, 1, 2, 0, 2, 0, 0) 42 | g23 = c(0, 1, 1, 0, 0, 1, 0, 2, 2, 1) 43 | g24 = c(1, 0, 0, 0, 1, 1, 0, 2, 0, 0) 44 | g25 = c(0, 0, 0, 1, 1, 2, 0, 2, 1, 0) 45 | g26 = c(1, 0, 1, 1, 0, 2, 0, 1, 0, 0) 46 | 47 | geno = rbind(g13, g14, g15, g16, g17, g18, g19, g20, g21, g22, g23, g24, g25, g26) 48 | 49 | rownames(geno) = seq(13, 26) 50 | 51 | # Prepare genomic relationship matrix G 52 | M = as.matrix(geno) 53 | p = colMeans(M)/2 54 | q = 1-p 55 | 56 | Za = sweep(M,2,2*p,"-") 57 | 58 | Gm = tcrossprod(Za) / (2 * (sum(p * q))) 59 | round(Gm, 3) 60 | 61 | # A22 and A22 inverse 62 | A22 = A[13:26,13:26] 63 | A22inv = solve(A22) 64 | 65 | # Blended G 66 | Gblended = 0.95*Gm + 0.05*A22 67 | 68 | # Tuned G 69 | a = ((mean(A22)*mean(diag(Gblended))) - (mean(Gblended)*mean(diag(A22)))) / ((1*mean(diag(Gblended)))-(mean(Gblended)*1)) 70 | b = ((1*mean(diag(A22))) - (mean(A22)*1)) / ((1*mean(diag(Gblended)))-(mean(Gblended)*1)) 71 | 72 | Gtuned1 = a + Gblended*b 73 | 74 | Ginv = solve(Gtuned1) 75 | 76 | GiAi = Ginv - A22inv 77 | 78 | # H-matrix 79 | Hinv = Ainv + rbind(cbind((rep(0, 12) %*% t(rep(0, 26)))), 80 | cbind((rep(0, 14) %*% t(rep(0, 12))), GiAi)) 81 | 82 | # Setting up the incidence matrices for the MME 83 | X = model.matrix(dyd ~ 1, data = data) 84 | 85 | data$a = factor(x = data$a, levels = data$a) 86 | Z = model.matrix(dyd ~ a - 1, data = data) 87 | 88 | alpha = 245/35.241 89 | 90 | y = na.omit(data$dyd) 91 | 92 | XpX = crossprod(X) 93 | XpZ = crossprod(X, Z) 94 | ZpX = crossprod(Z, X) 95 | ZpZ = crossprod(Z) 96 | Xpy = crossprod(X, y) 97 | Zpy = crossprod(Z, y) 98 | 99 | LHS = rbind(cbind(XpX, XpZ), 100 | cbind(ZpX, ZpZ + Hinv*alpha)) 101 | RHS = rbind(Xpy, 102 | Zpy) 103 | 104 | solutions = solve(LHS, RHS) 105 | 106 | round(solutions, 3) 107 | 108 | -------------------------------------------------------------------------------- /Content/Chapter_12/Chapter_12_2.R: -------------------------------------------------------------------------------- 1 | # Chapter 12 2 | ## APY 3 | 4 | # Clean the working environment 5 | rm(list = ls()) 6 | 7 | # Load packages 8 | library("tidyverse") 9 | # install.packages("tidyverse") 10 | 11 | # Source function 12 | source("APY_fja.R") 13 | 14 | # Example 12.2 ------------------------------------------------------------ 15 | 16 | # Prepare data 17 | a = seq(13, 26) 18 | s = c(NA, NA, 13, 15, 15, 14, 14, 14, 1, 14, 14, 14, 14, 14) 19 | d = c(NA, NA, 4, 2, 5, 6, 9, 9, 3, 8, 11, 10, 7, 12) 20 | dyd = c(9.0, 13.4, 12.7, 15.4, 5.9, 7.7, 10.2, 4.8, NA, NA, NA, NA, NA, NA) 21 | 22 | data = data.frame(a, s, d, dyd) 23 | 24 | # Genotypes 25 | g13 = c(2, 0, 1, 1, 0, 0, 0, 2, 1, 2) 26 | g14 = c(1, 0, 0, 0, 0, 2, 0, 2, 1, 0) 27 | g15 = c(1, 1, 2, 1, 1, 0, 0, 2, 1, 2) 28 | g16 = c(0, 0, 2, 1, 0, 1, 0, 2, 2, 1) 29 | g17 = c(0, 1, 1, 2, 0, 0, 0, 2, 1, 2) 30 | g18 = c(1, 1, 0, 1, 0, 2, 0, 2, 2, 1) 31 | g19 = c(0, 0, 1, 1, 0, 2, 0, 2, 2, 0) 32 | g20 = c(0, 1, 1, 0, 0, 1, 0, 2, 2, 0) 33 | g21 = c(2, 0, 0, 0, 0, 1, 2, 2, 1, 2) 34 | g22 = c(0, 0, 0, 1, 1, 2, 0, 2, 0, 0) 35 | g23 = c(0, 1, 1, 0, 0, 1, 0, 2, 2, 1) 36 | g24 = c(1, 0, 0, 0, 1, 1, 0, 2, 0, 0) 37 | g25 = c(0, 0, 0, 1, 1, 2, 0, 2, 1, 0) 38 | g26 = c(1, 0, 1, 1, 0, 2, 0, 1, 0, 0) 39 | 40 | geno = rbind(g13, g14, g15, g16, g17, g18, g19, g20, g21, g22, g23, g24, g25, g26) 41 | 42 | rownames(geno) = seq(13, 26) 43 | 44 | # Prepare genomic relationship matrix G 45 | M = as.matrix(geno) 46 | p = colMeans(M)/2 47 | q = 1-p 48 | 49 | Za = sweep(M,2,2*p,"-") 50 | 51 | G = tcrossprod(Za) / (2 * (sum(p * q))) 52 | round(G, 3) 53 | 54 | # Make matrix invertible 55 | fG = G + (diag(0.01, nrow(G))) 56 | Ginv = solve(fG) 57 | 58 | geno_ref = tibble(geno_id = rownames(geno), geno_order = seq(1:length(geno_id)) ) 59 | 60 | # Set number of core animals 61 | ncore = 4 62 | 63 | # Set seed to get the same random core animals as in the book 64 | set.seed(12345) 65 | 66 | index_core = sample_n(geno_ref[2], size = ncore) 67 | 68 | geno_ref2 = geno_ref %>% 69 | dplyr::mutate(core_status = if_else(geno_order %in% index_core$geno_order, true = 1, false = 0)) 70 | 71 | # Run APY inverse function 72 | apyginvlist = APY_inverse(G, geno_ref2) 73 | 74 | round(apyginvlist$APY_Ginv, 3) 75 | 76 | APYinv = apyginvlist$APY_Ginv 77 | 78 | # Setting up the incidence matrices for the MME 79 | apyginvlist$index_file$geno_id = as.integer(apyginvlist$index_file$geno_id) 80 | 81 | pheno_apy = inner_join(data, apyginvlist$index_file[, c(1,4)], by = c("a" = "geno_id")) %>% 82 | arrange(apy_order) 83 | 84 | X = model.matrix(dyd ~ 1, data = pheno_apy) 85 | 86 | pheno_apy$a = factor(x = pheno_apy$a, levels = pheno_apy$a) 87 | Z = model.matrix(dyd ~ -1 + a, data = pheno_apy) 88 | 89 | # Variance ratios 90 | alpha = 245/35.241 91 | 92 | y = na.omit(pheno_apy$dyd) 93 | 94 | XpX = crossprod(X) 95 | XpZ = crossprod(X, Z) 96 | 97 | ZpX = crossprod(Z, X) 98 | ZpZ = crossprod(Z) 99 | 100 | Xpy = crossprod(X, y) 101 | Zpy = crossprod(Z, y) 102 | 103 | LHS = rbind(cbind(XpX, XpZ), 104 | cbind(ZpX, ZpZ + APYinv*alpha)) 105 | 106 | RHS = rbind(Xpy, 107 | Zpy) 108 | 109 | solutions_APY = solve(LHS, RHS) 110 | 111 | # Reorder solutions 112 | solutions_APY_sorted = tibble(solutions_APY) %>% 113 | mutate(aid = rownames(solutions_APY)) %>% 114 | arrange(aid) 115 | 116 | round(solutions_APY_sorted[-1,1], 3) 117 | 118 | # Solve GBLUP 119 | 120 | # Setting up the incidence matrices for the MME 121 | X = model.matrix(dyd ~ 1, data = data) 122 | 123 | data$a = factor(x = data$a, levels = data$a) 124 | Z = model.matrix(dyd ~ -1 + a, data = data) 125 | 126 | # Variance ratios 127 | alpha = 245/35.241 128 | 129 | y = na.omit(data$dyd) 130 | 131 | XpX = crossprod(X) 132 | XpZ = crossprod(X, Z) 133 | 134 | ZpX = crossprod(Z, X) 135 | ZpZ = crossprod(Z) 136 | 137 | Xpy = crossprod(X, y) 138 | Zpy = crossprod(Z, y) 139 | 140 | LHS = rbind(cbind(XpX, XpZ), 141 | cbind(ZpX, ZpZ + Ginv*alpha)) 142 | 143 | RHS = rbind(Xpy, 144 | Zpy) 145 | 146 | solutions_GBLUP = solve(LHS, RHS) 147 | 148 | round(solutions_GBLUP, 3) 149 | 150 | # Correlations between DGV form direct G inverse and APY 151 | round(cor(solutions_APY_sorted[-1,1], solutions_GBLUP[-1,]), 3) 152 | 153 | -------------------------------------------------------------------------------- /Content/Chapter_13/Chapter_13_1.R: -------------------------------------------------------------------------------- 1 | # Chapter 13 2 | ## Pedigree models 3 | 4 | # Clean the working environment 5 | rm(list = ls()) 6 | 7 | # Load packages 8 | library("tidyverse") 9 | library("nadiv") 10 | # install.packages("tidyverse") 11 | # install.packages("nadiv") 12 | 13 | # Example 13.1 ------------------------------------------------------------ 14 | 15 | # Prepare pedigree 16 | a = seq(1, 12) 17 | s = c(NA, NA, NA, NA, 1, 3, 6, NA, 3, 3, 6, 6) 18 | d = c(NA, NA, NA, NA, 2, 4, 5, 5, 8, 8, 8, 8) 19 | ped = data.frame(a, s, d) 20 | 21 | # Create A-inverse 22 | Ainv = nadiv::makeAinv(ped)$Ainv 23 | 24 | # Create D-inverse 25 | Dinv = nadiv::makeD(ped)$Dinv 26 | 27 | # Prepare data 28 | pig = seq(5, 12) 29 | ww = c(17.0, 20.0, 18.0, 13.5, 20.0, 15.0, 25.0, 19.5) 30 | pen = c(1, 1, 1, 1, 2, 2, 2, 2) 31 | 32 | data = data.frame(pig, pen, ww) 33 | 34 | data$pen = as.factor(pen) 35 | data$pig= factor(x = data$pig, levels = ped$a) 36 | 37 | # Variances 38 | varA = 90 39 | varD = 80 40 | varE = 120 41 | 42 | # Variance ratios 43 | alpha1 = varE / varA 44 | alpha2 = varE / varD 45 | 46 | # Setting up the incidence matrices for the MME 47 | # Model: y = Xb + Za + Wd + e 48 | 49 | X = model.matrix(ww ~ -1 + pen, data = data) 50 | 51 | Z = model.matrix(ww ~ -1 + pig, data = data) 52 | 53 | W = Z 54 | 55 | XpX = crossprod(X) 56 | ZpZ = crossprod(Z) 57 | WpW = crossprod(W) 58 | 59 | Xpy = crossprod(X, data$ww) 60 | Zpy = crossprod(Z, data$ww) 61 | Wpy = crossprod(W, data$ww) 62 | 63 | XpZ = crossprod(X, Z) 64 | XpW = crossprod(X, W) 65 | 66 | ZpX = crossprod(Z, X) 67 | ZpW = crossprod(Z, W) 68 | 69 | WpX = crossprod(W, X) 70 | WpZ = crossprod(W, Z) 71 | 72 | LHS = rbind(cbind(XpX, XpZ, XpW), 73 | cbind(ZpX, ZpZ + (Ainv * alpha1), ZpW), 74 | cbind(WpX, WpZ, WpW + (Dinv * alpha2))) 75 | 76 | RHS = rbind(Xpy, 77 | Zpy, 78 | Wpy) 79 | 80 | solutions = solve(LHS, RHS) 81 | 82 | round(solutions, 3) 83 | 84 | -------------------------------------------------------------------------------- /Content/Chapter_13/Chapter_13_2.R: -------------------------------------------------------------------------------- 1 | # Chapter 13 2 | ## Genomic models 3 | 4 | # Clean the working environment 5 | rm(list = ls()) 6 | 7 | # Load packages 8 | library("tidyverse") 9 | # install.packages("tidyverse") 10 | 11 | # Example 13.3 ------------------------------------------------------------ 12 | 13 | # Read pedigree and SNP genotypes 14 | ped = read_table2(file = "ped_snp.txt", col_names = FALSE) 15 | 16 | colnames(ped) = c("Animal", "Sire", "Dam", "Sex", 17 | paste("Snp_", 1:(length(ped)-4), sep = "")) 18 | 19 | geno = ped[,-c(1:4)] 20 | 21 | # Prepare data 22 | pig = seq(5, 15) 23 | ww = c(17.0, 20.0, 18.0, 13.5, 20.0, 15.0, 25.0, 19.5, 22.5, 16.0, 24.5) 24 | pen = c(1, 1, 1, 1, 2, 2, 2, 2, 1, 1, 2) 25 | 26 | data = data.frame(pig, pen, ww) 27 | 28 | data$pen = as.factor(pen) 29 | data$pig = factor(x = data$pig, levels = ped$Animal) 30 | 31 | # Prepare genomic relationship matrices G and D 32 | M = as.matrix(geno) 33 | p = colMeans(M)/2 34 | q = 1-p 35 | 36 | Ma = sweep(M,2,2*p,"-") 37 | 38 | Md2 = matrix(0,nrow=nrow(M),ncol=ncol(M)) 39 | tmp = numeric(nrow(M)) 40 | for(i in 1:ncol(Md2)){ 41 | tmp[M[,i]==0] = -2*p[i]^2 42 | tmp[M[,i]==1] = 2*p[i]*q[i] 43 | tmp[M[,i]==2] = -2*q[i]^2 44 | Md2[,i] = tmp 45 | } 46 | 47 | GG = tcrossprod(Ma) / (2 * (sum(p * q))) 48 | round(GG, 3) 49 | 50 | DD = tcrossprod(Md2) / (sum((2 * p * q)^2)) 51 | round(DD, 3) 52 | 53 | # Make matrices invertible 54 | fG = GG + (diag(0.01, nrow(GG))) 55 | Ginv = solve(fG) 56 | 57 | fD = DD + (diag(0.01, nrow(DD))) 58 | Dinv = solve(fD) 59 | 60 | # Variances 61 | varA = 90 62 | varD = 80 63 | varE = 120 64 | 65 | # Variance ratios 66 | alpha1 = varE / varA 67 | alpha2 = varE / varD 68 | 69 | # Setting up the incidence matrices for the MME 70 | # Model: y = Xb + Za + Wd + e 71 | 72 | X = model.matrix(ww ~ -1 + pen, data = data) 73 | 74 | Z = model.matrix(ww ~ -1 + pig , data = data) 75 | 76 | W = Z 77 | 78 | XpX = crossprod(X) 79 | ZpZ = crossprod(Z) 80 | WpW = crossprod(W) 81 | 82 | Xpy = crossprod(X, data$ww) 83 | Zpy = crossprod(Z, data$ww) 84 | Wpy = crossprod(W, data$ww) 85 | 86 | XpZ = crossprod(X, Z) 87 | XpW = crossprod(X, W) 88 | 89 | ZpX = crossprod(Z, X) 90 | ZpW = crossprod(Z, W) 91 | 92 | WpX = crossprod(W, X) 93 | WpZ = crossprod(W, Z) 94 | 95 | LHS = rbind(cbind(XpX, XpZ, XpW), 96 | cbind(ZpX, ZpZ + (Ginv * alpha1), ZpW), 97 | cbind(WpX, WpZ, WpW + (Dinv * alpha2))) 98 | 99 | RHS = rbind(Xpy, 100 | Zpy, 101 | Wpy) 102 | 103 | solutions = solve(LHS, RHS) 104 | 105 | round(solutions, 3) 106 | 107 | # Example 13.5 ------------------------------------------------------------ 108 | 109 | # Assume genetic variance for epistatic effect 110 | varAA = 6 111 | 112 | # Variance ratios 113 | alpha3 = varE / varAA 114 | 115 | # Prepare epistatic additive by additive genomic relationship matrix 116 | HadamardGG = GG*GG 117 | k = sum(diag(HadamardGG))/15 118 | GAA = HadamardGG / k 119 | round(GAA, 3) 120 | 121 | # Make matrix invertible 122 | fGAA = GAA + (diag(0.01, nrow(GAA))) 123 | GAAinv = solve(fGAA) 124 | 125 | # Setting up the incidence matrices for the MME 126 | # Model: y = Xb + Za + Wd + Saa + e 127 | 128 | S = Z 129 | 130 | XpS = crossprod(X, S) 131 | ZpS = crossprod(Z, S) 132 | WpS = crossprod(W, S) 133 | 134 | SpX = crossprod(S, X) 135 | SpZ = crossprod(S, Z) 136 | SpW = crossprod(S, W) 137 | SpS = crossprod(S) 138 | 139 | Spy = crossprod(S, data$ww) 140 | 141 | rm(LHS, RHS) 142 | 143 | LHS = rbind(cbind(XpX, XpZ, XpW, XpS), 144 | cbind(ZpX, ZpZ + (Ginv * alpha1), ZpW, ZpS), 145 | cbind(WpX, WpZ, WpW + (Dinv * alpha2), WpS), 146 | cbind(SpX, SpZ, SpW, SpS + (GAAinv * alpha3))) 147 | 148 | RHS = rbind(Xpy, 149 | Zpy, 150 | Wpy, 151 | Spy) 152 | 153 | solutions_epi = solve(LHS, RHS) 154 | 155 | round(solutions_epi, 3) 156 | 157 | -------------------------------------------------------------------------------- /Content/Chapter_13/ped_snp.txt: -------------------------------------------------------------------------------- 1 | 1 0 0 M 2 2 0 0 1 1 1 0 1 1 0 0 1 0 1 2 0 1 0 1 2 | 2 0 0 F 1 1 1 1 2 0 1 0 2 2 0 1 0 1 1 1 0 0 0 0 3 | 3 0 0 M 1 2 1 0 2 0 1 1 2 2 0 1 2 0 2 2 0 0 1 0 4 | 4 0 0 F 1 1 0 0 2 0 2 2 2 2 1 1 0 1 0 2 1 0 1 0 5 | 5 1 2 F 1 1 1 1 1 0 2 0 1 2 0 0 0 1 1 2 0 0 0 1 6 | 6 3 4 M 2 1 0 0 2 0 1 1 2 2 0 1 1 1 1 2 0 0 2 0 7 | 7 6 5 M 2 1 0 0 1 0 2 1 1 2 0 1 0 1 1 2 0 0 1 1 8 | 8 0 5 F 2 2 0 0 1 0 2 1 1 2 0 0 1 0 2 1 0 0 0 1 9 | 9 3 8 M 2 2 0 0 1 0 2 2 2 2 0 1 2 0 2 1 0 0 0 0 10 | 10 3 8 F 1 2 0 0 2 0 2 2 2 2 0 1 2 0 2 1 0 0 0 0 11 | 11 6 8 F 2 1 0 0 1 0 1 0 1 2 0 0 1 0 2 1 0 0 1 0 12 | 12 6 8 F 2 1 0 0 1 0 2 1 1 2 0 1 0 1 1 2 0 0 1 1 13 | 13 7 10 M 2 1 0 0 2 0 2 2 2 2 0 1 1 1 1 1 0 0 1 0 14 | 14 9 12 M 2 1 0 0 1 0 2 2 2 2 0 1 1 0 2 1 0 0 0 1 15 | 15 7 11 M 2 1 0 0 0 0 2 0 1 2 0 0 0 0 2 1 0 0 0 1 16 | -------------------------------------------------------------------------------- /Content/Chapter_14/Chapter_14.R: -------------------------------------------------------------------------------- 1 | # Chapter 14 2 | ## Genomic models 3 | 4 | # Clean the working environment 5 | rm(list = ls()) 6 | 7 | # Load packages 8 | library("pedigreemm") 9 | library("tidyverse") 10 | library("MASS") 11 | # install.packages("pedigreemm") 12 | # install.packages("tidyverse") 13 | # install.packages("MASS") 14 | 15 | # Example 14.4 ------------------------------------------------------------ 16 | 17 | # Prepare data 18 | animal = seq(1, 12) 19 | sire = c(NA, NA, 1, 1, NA, NA, 5, 5, 1, 1, 5, 5) 20 | dam = c(NA, NA, 2, 3, NA, NA, 6, 7, 6, 7, 2, 3) 21 | records = c(11.0, 12.00, 13.00, 14.0, 15.00, 16.00, 17.0, 18.00, 19.00, 20.0, 21.00, 22.0) 22 | herd = c(2, 1, 2, 1, 1, 2, 1, 2, 1, 2, 1, 2) 23 | breed = c(1, 1, 1, 1, 2, 2, 2, 2, 12, 12, 12, 12) 24 | 25 | data = data.frame(animal, sire, dam, breed, herd, records) 26 | 27 | # Genotypes 28 | g1 = c(2, 0, 1, 1, 0, 0, 2, 2, 1, 2) 29 | g2 = c(1, 1, 0, 0, 1, 2, 0, 1, 1, 0) 30 | g3 = c(2, 1, 1, 0, 0, 1, 1, 1, 1, 1) 31 | g4 = c(2, 0, 2, 1, 0, 0, 2, 1, 2, 1) 32 | g5 = c(1, 1, 2, 1, 1, 0, 2, 2, 1, 2) 33 | g6 = c(0, 0, 1, 1, 0, 1, 0, 1, 2, 1) 34 | g7 = c(1, 1, 2, 0, 1, 0, 1, 1, 2, 2) 35 | g8 = c(2, 0, 2, 1, 0, 0, 2, 1, 1, 2) 36 | g9 = c(1, 0, 1, 1, 0, 0, 1, 2, 2, 1) 37 | g10 = c(2, 1, 2, 1, 0, 0, 2, 2, 2, 2) 38 | g11 = c(2, 2, 1, 0, 1, 1, 1, 1, 2, 1) 39 | g12 = c(2, 1, 2, 1, 0, 1, 1, 2, 1, 2) 40 | 41 | geno = rbind(g1, g2, g3, g4, g5, g6, g7, g8, g9, g10, g11, g12) 42 | 43 | rownames(geno) = seq(1, 12) 44 | 45 | # Genotype matrices for purebred 1 and 2 46 | M1 = geno[c(1:4),] 47 | M2 = geno[c(5:8),] 48 | 49 | # Matrix of marker alleles for the crossbreds derived from the purebred 1 and 2 50 | Q1 = matrix(c(1, 0, 1, 0, 0, 0, 1, 1, 1, 1, 51 | 1, 0, 1, 1, 0, 0, 1, 1, 1, 1, 52 | 1, 1, 1, 0, 1, 0, 1, 1, 1, 1, 53 | 1, 1, 1, 1, 0, 0, 1, 1, 1, 1), byrow = TRUE, nrow = 4) 54 | 55 | Q2 = matrix(c(0, 0, 0, 1, 0, 0, 0, 1, 1, 0, 56 | 1, 1, 1, 0, 0, 0, 1, 1, 1, 1, 57 | 1, 1, 0, 0, 0, 1, 0, 0, 1, 0, 58 | 1, 0, 1, 0, 0, 1, 0, 1, 0, 1), byrow = TRUE, nrow = 4) 59 | 60 | # SNP frequencies 61 | p1 = colSums(rbind(M1, Q1)) / (2*nrow(M1) + nrow(Q1)) 62 | 63 | p2 = colSums(rbind(M2, Q2)) / (2*nrow(M2) + nrow(Q2)) 64 | 65 | round(p1, 3) 66 | round(p2, 3) 67 | 68 | # Prepare genomic matrices 69 | Z1 = sweep(M1,2,2*p1,"-") 70 | round(Z1, 3) 71 | 72 | W1 = sweep(Q1,2,p1,"-") 73 | round(W1, 3) 74 | 75 | Z2 = sweep(M2,2,2*p2,"-") 76 | 77 | W2 = sweep(Q2,2,p2,"-") 78 | 79 | G11 = tcrossprod(Z1) / (2 * (sum(p1 * (1 - p1)))) 80 | G13 = tcrossprod(Z1, W1) / (2 * (sum(p1 * (1 - p1)))) 81 | G331 = tcrossprod(W1) / (2 * (sum(p1 * (1 - p1)))) 82 | 83 | G22 = tcrossprod(Z2) / (2 * (sum(p2 * (1 - p2)))) 84 | G23 = tcrossprod(Z2, W2) / (2 * (sum(p2 * (1 - p2)))) 85 | G332 = tcrossprod(W2) / (2 * (sum(p2 * (1 - p2)))) 86 | 87 | G1 = rbind(cbind(G11, G13), 88 | cbind(t(G13), G331)) 89 | 90 | round(G1, 3) 91 | 92 | G2 = rbind(cbind(G22, G23), 93 | cbind(t(G23), G332)) 94 | 95 | round(G2, 3) 96 | 97 | # Make matrices invertible 98 | fG1 = G1 + (diag(0.01, nrow(G1))) 99 | G1inv = solve(fG1) 100 | 101 | fG2 = G2 + (diag(0.01, nrow(G2))) 102 | G2inv = solve(fG2) 103 | 104 | # Add zeros for the opposite purebred 105 | G12 = cbind(G1inv[,1:4], matrix(0, 8, 4), G1inv[,5:8]) 106 | G10inv = rbind(G12[1:4,], matrix(0, 4, 12), G12[5:8,]) 107 | 108 | G22 = cbind(matrix(0, 8, 4), G2inv) 109 | G20inv = rbind(matrix(0, 4, 12), G22) 110 | 111 | # (Co)variances 112 | r11 = 0.25 113 | r22 = 0.25 114 | r33 = 1/4.75 115 | 116 | S1 = matrix(c(1, 0.92, 0.92, 1.5), nrow = 2) 117 | S2 = matrix(c(2, 1.385, 1.385, 1.5), nrow = 2) 118 | 119 | S1inv = solve(S1) 120 | S2inv = solve(S2) 121 | 122 | # Setting up the incidence matrices for the MME 123 | data$herd = as.factor(herd) 124 | data$animal = factor(animal, levels = c(1:12)) 125 | data$sire = factor(sire, levels = unique(data$sire)) 126 | data$dam = factor(dam, levels = unique(data$dam)) 127 | 128 | X = model.matrix(records ~ -1 + herd, data = data) 129 | 130 | X1 = rbind(X[1:4, 1:2], matrix(0, 8, 2)) 131 | X2 = rbind(matrix(0, 4, 2), X[5:8, 1:2], matrix(0, 4, 2)) 132 | X3 = rbind(matrix(0, 8, 2), X[9:12, 1:2]) 133 | 134 | y1 = c(data$records[1:4], rep(0,8)) 135 | y2 = c(rep(0,4), data$records[5:8], rep(0,4)) 136 | y3 = c(rep(0,8), data$records[9:12]) 137 | 138 | Zd0 = matrix(0, nrow(data), nrow(data)) 139 | 140 | Zd1 = Zd0 141 | diag(Zd1) = c(rep(1,4), rep(0,8)) 142 | 143 | Zd2 = Zd0 144 | diag(Zd2) = c(rep(0,4), rep(1,4), rep(0,4)) 145 | 146 | Zd13 = Zd0 147 | Zd13[9,1] = 0.5 148 | Zd13[10,1] = 0.5 149 | Zd13[11,2] = 0.5 150 | Zd13[12,3] = 0.5 151 | 152 | Zd23 = Zd0 153 | Zd23[9,6] = 0.5 154 | Zd23[10,7] = 0.5 155 | Zd23[11,5] = 0.5 156 | Zd23[12,5] = 0.5 157 | 158 | X1pX1 = (t(X1) * r11) %*% X1 159 | X2pX2 = (t(X2) * r22) %*% X2 160 | X3pX3 = (t(X3) * r33) %*% X3 161 | 162 | Zd1pX1 = (t(Zd1) * r11) %*% X1 163 | Zd2pX2 = (t(Zd2) * r22) %*% X2 164 | Zd13pX3 = (t(Zd13) * r33) %*% X3 165 | Zd23pX3 = (t(Zd23) * r33) %*% X3 166 | 167 | Zd1pZ1 = (t(Zd1) * r11) %*% Zd1 168 | Zd2pZ2 = (t(Zd2) * r22) %*% Zd2 169 | 170 | Zd13pZ13 = (t(Zd13) * r33) %*% Zd13 171 | Zd23pZ23 = (t(Zd23) * r33) %*% Zd23 172 | Zd23pZ13 = (t(Zd23) * r33) %*% Zd13 173 | 174 | ZM2 = matrix(0, 2, 2) 175 | ZM12 = matrix(0, 12, 2) 176 | ZM1212 = matrix(0, 12, 12) 177 | 178 | LHS = rbind(cbind(X1pX1, ZM2, ZM2, t(Zd1pX1), t(ZM12), t(ZM12), t(ZM12)), 179 | cbind(ZM2, X2pX2, ZM2, t(ZM12), t(ZM12), t(Zd2pX2), t(ZM12)), 180 | cbind(ZM2, ZM2, X3pX3, t(ZM12), t(Zd13pX3), t(ZM12), t(Zd23pX3)), 181 | cbind(Zd1pX1, ZM12, ZM12, Zd1pZ1 + S1inv[1,1] * G10inv, t(S1inv[1,2] * G10inv), t(ZM1212), t(ZM1212)), 182 | cbind(ZM12, ZM12, Zd13pX3, S1inv[1,2] * G10inv, Zd13pZ13 + S1inv[2,2] * G10inv, t(ZM1212), t(Zd23pZ13)), 183 | cbind(ZM12, Zd2pX2, ZM12, ZM1212, ZM1212, Zd2pZ2 + S2inv[1,1] * G20inv, t(S2inv[1,2] * G20inv)), 184 | cbind(ZM12, ZM12, Zd23pX3, ZM1212, Zd23pZ13, S2inv[1,2] * G20inv, Zd23pZ23 + S2inv[2,2] * G20inv )) 185 | 186 | # isSymmetric(LHS, check.attributes = FALSE) 187 | 188 | RHS = rbind((t(X1) * r11) %*% y1, 189 | (t(X2) * r22) %*% y2, 190 | (t(X3) * r33) %*% y3, 191 | (t(Zd1) * r11) %*% y1, 192 | (t(Zd13) * r33) %*% y3, 193 | (t(Zd2) * r22) %*% y2, 194 | (t(Zd23) * r33) %*% y3) 195 | 196 | solutions = MASS::ginv(LHS) %*% RHS 197 | 198 | round(solutions, 3) 199 | 200 | -------------------------------------------------------------------------------- /Content/Chapter_15/Chapter_15_1.R: -------------------------------------------------------------------------------- 1 | # Chapter 15 2 | ## Threshold model 3 | 4 | # Clean the working environment 5 | rm(list = ls()) 6 | 7 | # Load packages 8 | library("tidyverse") 9 | library("pedigreemm") 10 | # install.packages("tidyverse") 11 | # install.packages("pedigreemm") 12 | 13 | # Source function 14 | source("threshold_fja.R") 15 | 16 | # Example 15.1 ------------------------------------------------------------ 17 | 18 | # Prepare pedigree 19 | a = seq(1, 4) 20 | s = c(NA, NA, 1, 3) 21 | d = c(NA, NA, NA, NA) 22 | ped = data.frame(a, s, d) 23 | 24 | pedX = pedigree(label = a, 25 | sire = s, 26 | dam = d) 27 | 28 | Ainv = getAInv(ped = pedX) 29 | 30 | # Prepare data 31 | herd = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2) 32 | sex = c("Male", "Female", "Male", "Female", "Male", "Female", "Male", 33 | "Female", "Male", "Female", "Male", "Male", "Female", "Male", 34 | "Female", "Male", "Male", "Female", "Female", "Male") 35 | sire = c(1, 1, 1, 2, 2, 2, 3, 3, 3, 1, 1, 1, 2, 2, 3, 3, 4, 4, 4, 4) 36 | c1 = c(1, 1, 1, 0, 1, 3, 1, 0, 1, 2, 1, 0, 1, 1, 0, 0, 0, 1, 2, 2) 37 | c2 = c(0, 0, 0, 1, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0) 38 | c3 = c(0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 1, 0, 0, 0, 0) 39 | 40 | data = data.frame(herd, sex, sire, c1, c2, c3) 41 | data$total = data$c1 + data$c2 + data$c3 42 | 43 | # Variance components 44 | varS = 1/19 45 | varE = 40 46 | 47 | # Proportion before t1 48 | sum(data$c1)/sum(data$total) 49 | # Proportion before t2 50 | (sum(data$c1) + sum(data$c2))/sum(data$total) 51 | 52 | t1_init = 0.468 53 | t2_init = 1.080 54 | 55 | inits = matrix(c(t1_init, t2_init, rep(0, 6))) 56 | 57 | # Setting up the incidence matrices for the MME 58 | data$sex = as.factor(sex) 59 | data$sex = relevel(factor(sex), ref = "Male") 60 | data$herd = as.factor(herd) 61 | 62 | X = model.matrix(total ~ -1 + herd + sex, data = data) 63 | X = X[,-1] 64 | 65 | # Constraints: Herd "1" and Sex "Male" are set to zero 66 | 67 | data$sire = factor(x = data$sire, levels = pedX@label) 68 | Z = model.matrix(total ~ -1 + sire, data = data) 69 | 70 | # Solve using function "thr" 71 | solutions = thr(Ainv, X, Z, ncats = 3, 72 | cat = as.matrix(cbind(data$c1, data$c2, data$c3)), 73 | inits, 74 | ratio = 1/varS, 75 | disp = TRUE) 76 | 77 | -------------------------------------------------------------------------------- /Content/Chapter_15/Chapter_15_2.R: -------------------------------------------------------------------------------- 1 | # Chapter 15 2 | ## Joint Analysis of Quantitative and Binary Traits 3 | 4 | # Clean the working environment 5 | rm(list = ls()) 6 | 7 | # Example 15.2 ------------------------------------------------------------ 8 | 9 | # Prepare data 10 | bw = c(41, 37.5, 41.5, 40, 43, 42, 35, 46, 40.5, 39, 41.4, 43, 34, 47, 42, 44.5, 49, 41.6, 36, 42.7, 32.5, 44.4, 46, 47, 51, 39, 44.5, 40.5, 43.5, 42.5, 48.8, 38.5, 52, 48, 41, 50.5, 43.7, 51, 51.6, 45.3, 36.5, 50.5, 46, 45, 36, 43.5, 36.5) 11 | cd = c(rep(0,11),1,0,1,rep(0,9),1,1, rep(0,5),1, 0,0,0,0,rep(1,5),0,0,1,0,0,0,0) 12 | sex = c(1, 1, rep(2,8), 1, 1, 2, rep(1,6), 2,2,2,1,1,2,2,1,1,2,1,1,1,1,2,2,1,1,1,2,1,2,1,1,1,2,2,2) 13 | origin = c(rep(1,7), rep(2,3), rep(1,5), rep(2,2), 1, rep(2,5), 1, 1, 1, 2, rep(1,7), 2, 2, 2, 2, rep(1,7), 2, 2) 14 | season = c(1,1,1,2,2,2,2,1,1,2,1,1,2,2,2,2,2,1,1,1,2,2,2,2,2,2,1,1,1,2,2,2,2,2,1,1,2,2,1,1,1,2,2,2,2,1,1) 15 | sire = c(rep(1,10), rep(2,7), rep(3,6), rep(4,4), rep(5,11), rep(6,9)) 16 | 17 | data = data.frame(origin, sire, season, sex, bw, cd) 18 | data$sex = factor(data$sex) 19 | data$sex = relevel(factor(sex), ref = "2") 20 | data$season = factor(data$season) 21 | data$season = relevel(factor(season), ref = "2") 22 | data$origin = factor(data$origin) 23 | data$sire = factor(data$sire) 24 | 25 | # Prepare pedigree 26 | Ainv = matrix(c(1.424, 0.182, -0.667, -0.364, 0.000, 0.000, 27 | 0.182, 1.818, 0.364, -0.727, -0.364, -0.727, 28 | -0.667, 0.364, 1.788, 0.000, -0.727, -0.364, 29 | -0.364, -0.727, 0.000, 1.455, 0.000, 0.000, 30 | 0.000, -0.364, -0.727, 0.000, 1.455, 0.000, 31 | 0.000, -0.727, -0.364, 0.000, 0.000, 1.455), 32 | byrow = TRUE, 33 | ncol = 6) 34 | 35 | # (Co)variances 36 | R_0 = matrix(c(20, 2.089, 2.089, 1.036), nrow = 2) 37 | 38 | r_12 = R_0[1,2]/sqrt(R_0[1,1]*R_0[2,2]) 39 | 40 | b = (r_12/sqrt(R_0[1,1])) * (1/(sqrt(1-r_12^2))) 41 | 42 | G = matrix(c(0.7178, 0.1131, 0.1131, 0.0466), nrow = 2) 43 | 44 | Gc_0 = matrix(c(1, 0, -b, 1), byrow = TRUE, ncol = 2) 45 | 46 | Gc = Gc_0 %*% G %*% t(Gc_0) 47 | 48 | Gc_inv = solve(Gc) 49 | 50 | # Setting up the incidence matrices for the MME 51 | X1 = model.matrix(bw ~ -1 + origin + season + sex, data = data) 52 | Z1 = model.matrix(bw ~ -1 + sire, data = data) 53 | 54 | X2 = X1 55 | Z2 = Z1 56 | 57 | W = diag(nrow(data)) 58 | 59 | IR1 = diag(nrow(data)) * (1/R_0[1,1]) 60 | 61 | XpX = t(X1) %*% IR1 %*% X1 62 | ZpZ = t(Z1) %*% IR1 %*% Z1 63 | 64 | XpZ = t(X1) %*% IR1 %*% Z1 65 | ZpX = t(Z1) %*% IR1 %*% X1 66 | 67 | X2pX2 = t(X2) %*% W %*% X2 68 | Z2pZ2 = t(Z2) %*% W %*% Z2 69 | 70 | X2pZ2 = t(X2) %*% W %*% Z2 71 | Z2pX2 = t(Z2) %*% W %*% X2 72 | 73 | q = data$cd 74 | v = rep(0,6) 75 | 76 | Xpy = t(X1) %*% IR1 %*% data$bw 77 | Zpy = t(Z1) %*% IR1 %*% data$bw 78 | X2py2 = t(X2) %*% q 79 | Z2py2 = t(Z2) %*% q 80 | 81 | LHS = rbind(cbind(XpX, XpZ, matrix(0,4,4), matrix(0,4,6)), 82 | cbind(ZpX, ZpZ + (Ainv * Gc_inv[1,1]), matrix(0,6,4), (Ainv * Gc_inv[1,2])), 83 | cbind(matrix(0,4,4), matrix(0,4,6), X2pX2, X2pZ2), 84 | cbind(matrix(0,6,4), (Ainv * Gc_inv[2,1]), Z2pX2, Z2pZ2 + (Ainv * Gc_inv[2,2]))) 85 | 86 | RHS = rbind(Xpy, 87 | Zpy - (Ainv * Gc_inv[1,2]) %*% v, 88 | X2py2, 89 | Z2py2 - (Ainv * Gc_inv[2,2]) %*% v) 90 | 91 | solutions = solve(LHS, RHS) 92 | 93 | round(solutions, 4) 94 | 95 | # Presented solutions correspond to iteration 0. 96 | 97 | -------------------------------------------------------------------------------- /Content/Chapter_15/Chapter_15_3.R: -------------------------------------------------------------------------------- 1 | # Chapter 15 2 | ## Joint Analysis of Quantitative and Binary Traits 3 | ## Analysis using a linear model 4 | 5 | # Clean the working environment 6 | rm(list = ls()) 7 | 8 | # Example 15.2.2 Linear model --------------------------------------------- 9 | 10 | # Prepare data 11 | bw = c(41, 37.5, 41.5, 40, 43, 42, 35, 46, 40.5, 39, 41.4, 43, 34, 47, 42, 44.5, 49, 41.6, 36, 42.7, 32.5, 44.4, 46, 47, 51, 39, 44.5, 40.5, 43.5, 42.5, 48.8, 38.5, 52, 48, 41, 50.5, 43.7, 51, 51.6, 45.3, 36.5, 50.5, 46, 45, 36, 43.5, 36.5) 12 | cd = c(rep(0,11),1,0,1,rep(0,9),1,1, rep(0,5),1, 0,0,0,0,rep(1,5),0,0,1,0,0,0,0) 13 | sex = c(1, 1, rep(2,8), 1, 1, 2, rep(1,6), 2,2,2,1,1,2,2,1,1,2,1,1,1,1,2,2,1,1,1,2,1,2,1,1,1,2,2,2) 14 | origin = c(rep(1,7), rep(2,3), rep(1,5), rep(2,2), 1, rep(2,5), 1, 1, 1, 2, rep(1,7), 2, 2, 2, 2, rep(1,7), 2, 2) 15 | season = c(1,1,1,2,2,2,2,1,1,2,1,1,2,2,2,2,2,1,1,1,2,2,2,2,2,2,1,1,1,2,2,2,2,2,1,1,2,2,1,1,1,2,2,2,2,1,1) 16 | sire = c(rep(1,10), rep(2,7), rep(3,6), rep(4,4), rep(5,11), rep(6,9)) 17 | 18 | data = data.frame(origin, sire, season, sex, bw, cd) 19 | data$sex = factor(data$sex) 20 | data$sex = relevel(factor(sex), ref = "2") 21 | data$season = factor(data$season) 22 | data$season = relevel(factor(season), ref = "2") 23 | data$origin = factor(data$origin) 24 | data$sire = factor(data$sire) 25 | 26 | y2 = c(bw, cd) 27 | 28 | # Prepare pedigree 29 | Ainv = matrix(c(1.424, 0.182, -0.667, -0.364, 0.000, 0.000, 30 | 0.182, 1.818, 0.364, -0.727, -0.364, -0.727, 31 | -0.667, 0.364, 1.788, 0.000, -0.727, -0.364, 32 | -0.364, -0.727, 0.000, 1.455, 0.000, 0.000, 33 | 0.000, -0.364, -0.727, 0.000, 1.455, 0.000, 34 | 0.000, -0.727, -0.364, 0.000, 0.000, 1.455), 35 | byrow = TRUE, 36 | ncol = 6) 37 | 38 | # (Co)variances 39 | G_0 = matrix(c(0.7178, 0.1131, 0.1131, 0.0466), nrow = 2) 40 | R_0 = matrix(c(20, 2.089, 2.089, 1.036), nrow = 2) 41 | 42 | G_0inv = solve(G_0) 43 | R_0inv = solve(R_0) 44 | 45 | # Setting up the incidence matrices for the MME 46 | X = model.matrix(bw ~ -1 + origin + season + sex, data = data) 47 | 48 | I = diag(1, 2) 49 | IX = kronecker(I, X) 50 | 51 | Z = model.matrix(bw ~ -1 + sire, data = data) 52 | 53 | IZ = kronecker(I, Z) 54 | 55 | XRX = crossprod(IX, kronecker(R_0inv, diag(1, nrow(data)))) %*% IX 56 | XRZ = crossprod(IX, kronecker(R_0inv, diag(1, nrow(data)))) %*% IZ 57 | 58 | ZRZ = crossprod(IZ, kronecker(R_0inv, diag(1, nrow(data)))) %*% IZ 59 | ZRX = crossprod(IZ, kronecker(R_0inv, diag(1, nrow(data)))) %*% IX 60 | 61 | XRy = crossprod(IX, kronecker(R_0inv, diag(1, nrow(data)))) %*% y2 62 | ZRy = crossprod(IZ, kronecker(R_0inv, diag(1, nrow(data)))) %*% y2 63 | 64 | AiGi = kronecker(G_0inv, Ainv) 65 | 66 | LHS = rbind(cbind(XRX, XRZ), 67 | cbind(ZRX, ZRZ + AiGi)) 68 | 69 | RHS = rbind(XRy, 70 | ZRy) 71 | 72 | solutions = solve(LHS, RHS) 73 | 74 | round(solutions, 4) 75 | 76 | # Please note ordering of solutions is different compared to the book; 77 | # Fixed effects for both traits first, then the sire effects for both traits. 78 | 79 | -------------------------------------------------------------------------------- /Content/Chapter_15/threshold_fja.R: -------------------------------------------------------------------------------- 1 | ## The non-linear (threshold) model for categorical traits. 2 | 3 | ## Arguments 4 | ## Ainv: inverse of the additive relationship matrix 5 | ## X: incidence matrix relating data to fixed effects 6 | ## Z: incidence matrix relating data to individuals 7 | ## ncats: number of categories in the data 8 | ## cat: matrix of category of response 9 | ## inits: vecotor of initial values for the threshold effects, fixed effects and random effects 10 | ## ratio: ratio of the variance components 11 | ## disp: a logical value. If true, show the solutions at each iteration 12 | 13 | 14 | ## Literature1 : Mrode, R.A. 2005. Linear Models for the Prediction of Animal Breeding Values. CAB International, Oxon, UK. 15 | ## Literature 2: Gianola, D. and Foulley, J.L. 1983. Sire Evaluation for Ordered Categorical Data with a Threshold Model. Genetic Selection Evolution. 16 | 17 | ## Author: Gota Morota 18 | ## Create: 16-Apr-2010 19 | ## Last-Modified: 18-Apr-2010 20 | ## License: GPLv3 or later 21 | 22 | `thr` <- 23 | function(Ainv, X, Z, ncats, cat, inits, ratio, disp){ 24 | 25 | # starting values 26 | B <- inits 27 | # total 28 | total <- apply(cat, 1, sum) 29 | # number of records 30 | n <- length(total) 31 | # number of category 32 | m <- ncats 33 | # number of threshold 34 | t <- m-1 35 | 36 | diff <- 1 37 | it = 0 38 | while (diff > 10E-9){ 39 | it = it + 1 40 | # nannja kore 41 | tmp <- cbind(X, Z)%*%B[(t+1):dim(B)[1]] 42 | d <- matrix(0, nrow=n, ncol=t) 43 | for (i in 1:n){ 44 | for (j in 1:t){ 45 | d[i, j] <- B[j] - tmp[i] 46 | } 47 | } 48 | 49 | phi <- dnorm(d) 50 | Phi <- pnorm(d) 51 | 52 | P <- matrix(0, nrow=n, ncol=m) 53 | for (i in 1:n){ 54 | for (j in 2:m){ 55 | if (j == m){ 56 | P[i,j] <- 1.0 - Phi[i, j-1] 57 | } 58 | else { 59 | P[i,j] <- Phi[i,j] - Phi[i,j-1] 60 | } 61 | } 62 | } 63 | 64 | P[,1] <- Phi[,1] 65 | 66 | 67 | # W matrix 68 | w <- as.numeric() 69 | for (i in 1:n){ 70 | # first element 71 | tmp1 <- ((0-phi[i,1])^2/(Phi[i,1]) ) 72 | # last element 73 | tmp2 <- ((phi[i,t] - 0)^2/(P[i,m]) ) 74 | tmp3 <- 0 75 | for (j in 2:t){ 76 | for (k in 2:(m-1)){ 77 | #print(k) 78 | tmp3 <- tmp3 + ( (phi[i,j-1]-phi[i,j])^2/(P[i,k]) ) 79 | } 80 | } 81 | 82 | w[i] <- total[i]*(tmp1 + tmp2 + tmp3) 83 | } 84 | 85 | W <- diag(w) 86 | 87 | 88 | 89 | 90 | # v vector 91 | v <- as.numeric() 92 | for (i in 1:n){ 93 | # first element 94 | tmp1 <- cat[i,1]*((0-phi[i,1])/(Phi[i,1]) ) 95 | # last element 96 | tmp2 <- cat[i,m]*((phi[i,t] - 0)/(P[i,m]) ) 97 | tmp3 <- 0 98 | for (j in 2:t){ 99 | for (k in 2:(m-1)){ 100 | tmp3 <- tmp3 + cat[i,k]*( (phi[i,j-1]-phi[i,j])/(P[i,k]) ) 101 | } 102 | } 103 | 104 | v[i] <-(tmp1 + tmp2 + tmp3) 105 | } 106 | 107 | 108 | 109 | # L matrix 110 | L <- matrix(0, ncol=m-1, nrow=n) 111 | for (i in 1:n){ 112 | 113 | for (j in 1:t){ 114 | if (j == 1){ 115 | L[i,j] <- -total[i]*phi[i,j]* ((phi[i,j] - 0 )/P[i,j] - (phi[i,j+1] - phi[i,j] )/P[i,j+1] ) 116 | 117 | } 118 | else if (j == t){ 119 | L[i,j] <- -total[i]*phi[i,j]* ((phi[i,j] - phi[i,j-1] )/P[i,j] - (0 - phi[i,j] )/P[i,j+1] ) 120 | 121 | } 122 | else { 123 | L[i,j] <- -total[i]*phi[i,j]* ((phi[i,j] - phi[i,j-1] )/P[i,j] - (phi[i,j+1] - phi[i,j] )/P[i,j+1] ) 124 | 125 | } 126 | 127 | } 128 | } 129 | 130 | 131 | # Q matrix 132 | Q <- matrix(0, ncol=t, nrow=t) 133 | for (k in 1:t){ 134 | tmp1 <- 0 135 | for (j in 1:n){ 136 | tmp1 <- tmp1 + total[j]*phi[j,k]^2*( (P[j,k]+P[j,k+1])/(P[j,k]*P[j,k+1]) ) 137 | } 138 | Q[k,k] <- tmp1 139 | for (l in (k+1):t){ 140 | tmp2 <- 0 141 | if (l > t) break 142 | for (j in 1:n){ 143 | tmp2 <- tmp2 + -total[j]*( (phi[j,k]*phi[j,k+1])/(P[j,k+1]) ) 144 | } 145 | 146 | Q[k,l] <- tmp2 147 | Q[l,k] <- Q[k,l] 148 | } 149 | 150 | } 151 | 152 | 153 | # p matrix 154 | p <- as.numeric() 155 | 156 | 157 | for (k in 1:t) { 158 | tmp <- 0 159 | for (j in 1:n ){ 160 | tmp <- tmp + phi[j,k]*( (cat[j,k])/(P[j,k]) - (cat[j,k+1])/(P[j,k+1]) ) 161 | 162 | } 163 | p[k] <- tmp 164 | 165 | } 166 | 167 | 168 | mme1 <- cbind(Q, t(L)%*%X, t(L)%*%Z) 169 | mme2 <- cbind(t(X)%*%L, t(X)%*%W%*%X, t(X)%*%W%*%Z) 170 | mme3 <- cbind(t(Z)%*%L, t(Z)%*%W%*%X, t(Z)%*%W%*%Z + Ainv*ratio) 171 | LHS <- rbind(mme1, mme2, mme3) 172 | 173 | mme4 <- matrix(p) 174 | mme5 <- t(X)%*%v 175 | mme6 <- t(Z)%*%v - ratio*Ainv%*%matrix(B[(dim(B)[1]-length(s)+1):dim(B)[1],]) 176 | RHS <- rbind(mme4, mme5, mme6) 177 | 178 | newB <- solve(LHS)%*%RHS 179 | diff <- ( sum((B + newB - B)^2) ) /sum((B + newB)^2) 180 | B <- B + newB 181 | if (disp == TRUE){ 182 | cat('\n') 183 | cat("iteration ", it, '\n') 184 | print(B) 185 | } 186 | 187 | 188 | } 189 | 190 | 191 | } -------------------------------------------------------------------------------- /Content/Chapter_17/Chapter_17.R: -------------------------------------------------------------------------------- 1 | # Chapter 17 2 | ## REML 3 | 4 | # Clean the working environment 5 | rm(list = ls()) 6 | 7 | # Load packages 8 | library("pedigreemm") 9 | # install.packages("pedigreemm") 10 | 11 | # Example 17.7 ------------------------------------------------------------ 12 | 13 | # Prepare pedigree 14 | a = seq(1, 8) 15 | s = c(NA, NA, NA, 1, 3, 1, 4, 3) 16 | d = c(NA, NA, NA, NA, 2, 2, 5, 6) 17 | ped = data.frame(a, s, d) 18 | 19 | pedX = pedigree(label = a, 20 | sire = s, 21 | dam = d) 22 | 23 | A = getA(ped = pedX) 24 | 25 | Ainv = getAInv(ped = pedX) 26 | 27 | # Prepare data 28 | calf = seq(4,8) 29 | sex = c("Male", "Female", "Female", "Male", "Male") 30 | wwg = c(2.6, 0.1, 1.0, 3.0, 1.0) 31 | 32 | data = data.frame(calf, sex, wwg) 33 | 34 | data$sex = as.factor(sex) 35 | data$sex = relevel(factor(sex), ref = "Male") 36 | data$calf = factor(x = data$calf, levels = pedX@label) 37 | 38 | # Variance components 39 | varA = 0.2 40 | varE = 0.4 41 | 42 | # Variance ratios 43 | alpha = varE/varA 44 | 45 | # Setting up the incidence matrices for the MME 46 | X = model.matrix(wwg ~ -1 + sex, data = data) 47 | Z = model.matrix(wwg ~ -1 + calf, data = data) 48 | 49 | XpX = crossprod(X) 50 | XpZ = crossprod(X, Z) 51 | ZpX = crossprod(Z, X) 52 | ZpZ = crossprod(Z) 53 | Xpy = crossprod(X, data$wwg) 54 | Zpy = crossprod(Z, data$wwg) 55 | 56 | LHS = rbind(cbind(XpX, XpZ), 57 | cbind(ZpX, ZpZ + Ainv*alpha)) 58 | RHS = rbind(Xpy, 59 | Zpy) 60 | 61 | solutions = solve(LHS, RHS) 62 | 63 | round(solutions, 3) 64 | 65 | res = data$wwg - X%*%solutions[1:2] - Z%*%solutions[3:10] 66 | 67 | round(res,4) 68 | 69 | CM = solve(LHS) 70 | C22 = CM[3:10, 3:10] 71 | traceAC = sum(diag(Ainv %*% C22)) 72 | 73 | apAa = t(solutions[3:10]) %*% Ainv %*% solutions[3:10] 74 | 75 | V = Z %*% A %*% t(Z) * varA + diag(5) * varE 76 | 77 | Vinv = solve(V) 78 | 79 | P = Vinv - Vinv %*% X %*% solve(t(X) %*% Vinv %*% X) %*% t(X) %*% Vinv 80 | 81 | ypPy = t(data$wwg) %*% P %*% data$wwg 82 | 83 | round(ypPy, 4) 84 | 85 | L = 0.5*(-ypPy - log(det(V)) - log(det(t(X) %*% Vinv %*% X))) 86 | round(L, 4) 87 | 88 | D1E = 0.5*(t(res)%*%res/varE^2 - (5-2-8)/varE - traceAC/varA) 89 | D1A = 0.5*(apAa/varA^2 - 8/varA + traceAC*varE/varA^2) 90 | 91 | A11 = -0.5*((t(res)%*%P%*%res)/varE^2) 92 | A12 = -0.5*(t(solutions[3:10])%*%t(Z)%*%P%*%res) / (varE*varA) 93 | A22 = -0.5*(t(solutions[3:10])%*%t(Z)%*%P%*%Z%*%solutions[3:10]) / varA^2 94 | 95 | Ainf = rbind(cbind(-A11, -A12), 96 | cbind(-A12, -A22)) 97 | 98 | Ainf_inv = solve(Ainf) 99 | 100 | round(Ainf, 4) 101 | round(Ainf_inv, 4) 102 | 103 | varAE_01 = rbind(varE, varA) + Ainf_inv %*% rbind(D1E, D1A) 104 | round(varAE_01, 4) 105 | 106 | # Expectation maximization (EM) REML 107 | varA_01 = (apAa + traceAC*varE) / 8 108 | varE_01 = t(res)%*%data$wwg / (5 - 2) 109 | 110 | round(varA_01, 4) 111 | round(varE_01, 4) 112 | 113 | 114 | -------------------------------------------------------------------------------- /Content/Chapter_18/Chapter_18.R: -------------------------------------------------------------------------------- 1 | # Chapter 18 2 | ## Gibbs sampling 3 | 4 | # Clean the working environment 5 | rm(list = ls()) 6 | 7 | # Load packages 8 | library("pedigreemm") 9 | # install.packages("pedigreemm") 10 | 11 | # Example 18.1 ------------------------------------------------------------ 12 | 13 | # Prepare pedigree 14 | a = seq(1, 8) 15 | s = c(NA, NA, NA, 1, 3, 1, 4, 3) 16 | d = c(NA, NA, NA, NA, 2, 2, 5, 6) 17 | ped = data.frame(a, s, d) 18 | 19 | pedX = pedigree(label = a, 20 | sire = s, 21 | dam = d) 22 | 23 | Ainv = getAInv(ped = pedX) 24 | 25 | # Prepare data 26 | calf = seq(4,8) 27 | sex = c("Male", "Female", "Female", "Male", "Male") 28 | wwg = c(4.5, 2.9, 3.9, 3.5, 5.0) 29 | 30 | data = data.frame(calf, sex, wwg) 31 | 32 | data$calf = factor(x = data$calf, levels = pedX@label) 33 | data$sex = as.factor(sex) 34 | data$sex = relevel(factor(sex), ref = "Male") 35 | 36 | # Variance components 37 | varA = 20 38 | varE = 40 39 | 40 | # Variance ratios 41 | alpha = varE/varA 42 | 43 | # Degree of belief 44 | ve = -2 45 | vu = -2 46 | 47 | # Prior 48 | se = 0 49 | su = 0 50 | 51 | # Setting up the incidence matrices for the MME 52 | X = model.matrix(wwg ~ -1 + sex, data = data) 53 | Z = model.matrix(wwg ~ -1 + calf, data = data) 54 | 55 | XpX = crossprod(X) 56 | XpZ = crossprod(X, Z) 57 | ZpX = crossprod(Z, X) 58 | ZpZ = crossprod(Z) 59 | Xpy = crossprod(X, data$wwg) 60 | Zpy = crossprod(Z, data$wwg) 61 | 62 | LHS = rbind(cbind(XpX, XpZ), 63 | cbind(ZpX, ZpZ + Ainv * alpha)) 64 | RHS = rbind(Xpy, 65 | Zpy) 66 | 67 | solutions = solve(LHS, RHS) 68 | 69 | round(solutions, 3) 70 | 71 | # Set number of parameters 72 | obs = length(data$wwg) 73 | lev = ncol(X) + ncol(Z) 74 | 75 | # Set seed to get the same random numbers as in the book 76 | set.seed(12345) 77 | # rnorm(lev) 78 | 79 | theta = rep(0, lev) 80 | mumu = rep(0, lev) 81 | 82 | for(i in 1:lev){ 83 | mu = (RHS[i] - LHS[i,]%*%theta - LHS[i,i]*theta[i])/LHS[i,i] 84 | mumu[i] = mu 85 | var = varE/LHS[i,i] 86 | theta[i] = rnorm(1, mean = mu, sd = sqrt(var)) 87 | } 88 | 89 | b = theta[1:ncol(X)] 90 | u = theta[(ncol(X) + 1):(lev)] 91 | e = data$wwg - X%*%b - Z%*%u 92 | 93 | round(e, 3) 94 | 95 | epe = t(e) %*% e 96 | round(epe, 3) 97 | 98 | # Draw sigma2e 99 | df = obs + ve 100 | S = epe + se 101 | sigma2e = S / rchisq(1, df=df) 102 | 103 | # Draw sigma2u 104 | df = ncol(Z) + vu 105 | S = t(u) %*% Ainv %*% u + su 106 | sigma2u = S / rchisq(1, df=df) 107 | 108 | round(sigma2e, 3) 109 | round(sigma2u, 3) 110 | 111 | # The next round of iteration is then commenced using the updated values computed for the parameters. 112 | 113 | -------------------------------------------------------------------------------- /Content/Chapter_19/Chapter_19.R: -------------------------------------------------------------------------------- 1 | # Chapter 19 2 | ## Gauss-Seidel 3 | 4 | # Clean the working environment 5 | rm(list = ls()) 6 | 7 | # Load packages 8 | library("pedigreemm") 9 | # install.packages("pedigreemm") 10 | 11 | # Example 19.2 ------------------------------------------------------------ 12 | 13 | # Prepare pedigree 14 | a = seq(1, 8) 15 | s = c(NA, NA, NA, 1, 3, 1, 4, 3) 16 | d = c(NA, NA, NA, NA, 2, 2, 5, 6) 17 | ped = data.frame(a, s, d) 18 | 19 | pedX = pedigree(label = a, 20 | sire = s, 21 | dam = d) 22 | 23 | Ainv = getAInv(ped = pedX) 24 | 25 | # Prepare data 26 | calf = seq(4,8) 27 | sex = c("Male", "Female", "Female", "Male", "Male") 28 | wwg = c(4.5, 2.9, 3.9, 3.5, 5.0) 29 | 30 | data = data.frame(calf, sex, wwg) 31 | 32 | data$calf = factor(x = data$calf, levels = pedX@label) 33 | data$sex = as.factor(sex) 34 | data$sex = relevel(factor(sex), ref = "Male") 35 | 36 | # Variance components 37 | varA = 20 38 | varE = 40 39 | 40 | # Variance ratios 41 | alpha = varE / varA 42 | 43 | # Setting up the incidence matrices for the MME 44 | X = model.matrix(wwg ~ -1 + sex, data = data) 45 | Z = model.matrix(wwg ~ calf - 1, data = data) 46 | 47 | XpX = crossprod(X) 48 | XpZ = crossprod(X, Z) 49 | ZpX = crossprod(Z, X) 50 | ZpZ = crossprod(Z) 51 | Xpy = crossprod(X, data$wwg) 52 | Zpy = crossprod(Z, data$wwg) 53 | 54 | LHS = rbind(cbind(XpX, XpZ), 55 | cbind(ZpX, ZpZ + Ainv*alpha)) 56 | RHS = rbind(Xpy, 57 | Zpy) 58 | 59 | # Initial values of sex and animal effects are set as in the book 60 | solutions = c(4.333, 3.400, 0.000, 0.000, 0.000, 0.167, -0.500, 0.500, -0.833, 0.667) 61 | convergence = 1 62 | 63 | # Set the number of iterations 64 | # Here we use 20 as in the book 65 | iterations = 20 66 | 67 | solutions_all = data.frame(solutions) 68 | solutions_all = rbind(solutions_all, convergence) 69 | 70 | for (i in 1:iterations){ 71 | solutions_old = solutions 72 | for (j in 1:ncol(LHS)){ 73 | solutions[j] = (RHS[j] - LHS[j,-j]%*%solutions[-j])/LHS[j,j] 74 | } 75 | convergence = (sum((solutions - solutions_old)^2)) / sum(solutions^2) 76 | solutions_new = data.frame(solutions) 77 | solutions_new = rbind(solutions_new, convergence) 78 | solutions_all = cbind(solutions_all, solutions_new) 79 | } 80 | 81 | round(solutions_all, 3) 82 | 83 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Examples in R 2 | 3 | - **Chapter 4** 4 | - [A Model for an Animal Evaluation (Animal Model)](/Content/Chapter_04/Chapter_04_1.R) 5 | - [Accuracy of evaluations](/Content/Chapter_04/Chapter_04_1.R) 6 | - [A Sire Model](/Content/Chapter_04/Chapter_04_1.R) 7 | - [Reduced Animal Model](/Content/Chapter_04/Chapter_04_2.R) 8 | - [Animal Model with Groups](/Content/Chapter_04/Chapter_04_3.R) 9 | - **Chapter 5** 10 | - [Repeatability Model](/Content/Chapter_05/Chapter_05_1.R) 11 | - [Model with Common Environmental Effects](/Content/Chapter_05/Chapter_05_2.R) 12 | - **Chapter 6** 13 | - [Multivariate Models: Equal Design Matrices and No Missing Records](/Content/Chapter_06/Chapter_06.R) 14 | - **Chapter 8** 15 | - [Animal Model for a Maternal Trait](/Content/Chapter_08/Chapter_08.R) 16 | - **Chapter 9** 17 | - [Animal Model with Social Interaction Effects](/Content/Chapter_09/Chapter_09_1.R) 18 | - [Model with no Associative Effects](/Content/Chapter_09/Chapter_09_2.R) 19 | - **Chapter 10** 20 | - [Fixed Regression Model](/Content/Chapter_10/Chapter_10.R) 21 | - [Random Regression Model](/Content/Chapter_10/Chapter_10.R) 22 | - **Chapter 11** 23 | - [SNP-BLUP Model](/Content/Chapter_11/Chapter_11_1.R) 24 | - [GBLUP Model](/Content/Chapter_11/Chapter_11_1.R) 25 | - [Computing SNP solutions from GBLUP](/Content/Chapter_11/Chapter_11_1.R) 26 | - [Computing base population allele frequencies](/Content/Chapter_11/Chapter_11_1.R) 27 | - [Haplotype Models](/Content/Chapter_11/Chapter_11_2.R) 28 | - [Multivariate Genomic Models](/Content/Chapter_11/Chapter_11_3.R) 29 | - **Chapter 12** 30 | - [Single-step GBLUP](/Content/Chapter_12/Chapter_12_1.R) 31 | - [APY Approach](/Content/Chapter_12/Chapter_12_2.R) 32 | - **Chapter 13** 33 | - [Non-additive: Pedigree Models](Content/Chapter_13/Chapter_13_1.R) 34 | - [Non-additive: Genomic Models](Content/Chapter_13/Chapter_13_2.R) 35 | - **Chapter 14** 36 | - [Multibreed and Crossbred Analyses: Genomic Models](/Content/Chapter_14/Chapter_14.R) 37 | - **Chapter 15** 38 | - [Threshold Model](/Content/Chapter_15/Chapter_15_1.R) 39 | - [Joint Analysis of Quantitative and Binary Traits](/Content/Chapter_15/Chapter_15_2.R) 40 | - [Joint Analysis of Quantitative and Binary Traits - Analysis using a linear model](/Content/Chapter_15/Chapter_15_3.R) 41 | - **Chapter 17** 42 | - [REML](/Content/Chapter_17/Chapter_17.R) 43 | - **Chapter 18** 44 | - [Gibbs Sampling](/Content/Chapter_18/Chapter_18.R) 45 | - **Chapter 19** 46 | - [Gauss-Seidel Iteration](/Content/Chapter_19/Chapter_19.R) 47 | --------------------------------------------------------------------------------