Problem 1: Marker Effect Model
We are given the dataset that is shown in the table below. This
dataset contains gentyping results of 10 for 2 SNP loci.
1 |
0 |
0 |
156 |
2 |
1 |
0 |
168 |
3 |
0 |
1 |
161 |
4 |
1 |
0 |
164 |
5 |
-1 |
0 |
128 |
6 |
-1 |
1 |
124 |
7 |
0 |
-1 |
143 |
8 |
1 |
1 |
178 |
9 |
1 |
0 |
163 |
10 |
0 |
0 |
151 |
The above data can be read from:
https://charlotte-ngs.github.io/lbgfs2022/data/geno_data.csv
Your Task
- The goal of this problem is to estimate SNP marker effects using a
marker effect model
. Because we have just 2 SNP loci, you
can use a fixed effects linear model with the 2 loci as fixed effects.
Furthermore you can also include a fixed intercept into the model.
- Specify all the model components including the vector of
observations, the design matrix \(X\),
the vector of unknowns and the vector of residuals.
- You can use the R-function
lm()
to get the solutions
for estimates of the unknown SNP effects.
Your Solution
- Set up the regression model
- Use lm() to get the regression coefficients as marker effects
Problem 2: Breeding Value Model
Use the same data as in Problem 1 to estimate genomic breeding values
using a breeding value model
.
Hints
- The only fixed effect in this model is the mean \(\mu\) which is the same for all
observations.
- You can use the following function to compute the genomic
relationship matrix
#' Compute genomic relationship matrix based on data matrix
computeMatGrm <- function(pmatData) {
matData <- pmatData
# check the coding, if matData is -1, 0, 1 coded, then add 1 to get to 0, 1, 2 coding
if (min(matData) < 0) matData <- matData + 1
# Allele frequencies, column vector of P and sum of frequency products
freq <- apply(matData, 2, mean) / 2
P <- 2 * (freq - 0.5)
sumpq <- sum(freq*(1-freq))
# Changing the coding from (0,1,2) to (-1,0,1) and subtract matrix P
Z <- matData - 1 - matrix(P, nrow = nrow(matData),
ncol = ncol(matData),
byrow = TRUE)
# Z%*%Zt is replaced by tcrossprod(Z)
return(tcrossprod(Z)/(2*sumpq))
}
matG <-computeMatGrm(pmatData = t(mat_geno_snp))
matG_star <- matG + 0.01 * diag(nrow = nrow(matG))
n_min_eig_matG_start <- min(eigen(matG_star, only.values = TRUE)$values)
if (n_min_eig_matG_start < sqrt(.Machine$double.eps))
stop(" *** Genomic relationship matrix singular with smallest eigenvalue: ",
n_min_eig_matG_start)
- The resulting genomic relationship matrix is given by
\[G = \begin{bmatrix} 0.093 & -0.125
& -0.125 & -0.125 & 0.292 & 0.083 & 0.292 &
-0.333 & -0.125 & 0.083 \\-0.125 & 0.718 & -0.333 &
0.708 & -0.958 & -1.167 & 0.083 & 0.5 & 0.708 &
-0.125 \\-0.125 & -0.333 & 0.718 & -0.333 & 0.083 &
0.917 & -0.958 & 0.5 & -0.333 & -0.125 \\-0.125 &
0.708 & -0.333 & 0.718 & -0.958 & -1.167 & 0.083
& 0.5 & 0.708 & -0.125 \\0.292 & -0.958 & 0.083
& -0.958 & 1.552 & 1.333 & 0.5 & -1.167 & -0.958
& 0.292 \\0.083 & -1.167 & 0.917 & -1.167 & 1.333
& 2.177 & -0.75 & -0.333 & -1.167 & 0.083 \\0.292
& 0.083 & -0.958 & 0.083 & 0.5 & -0.75 & 1.552
& -1.167 & 0.083 & 0.292 \\-0.333 & 0.5 & 0.5 &
0.5 & -1.167 & -0.333 & -1.167 & 1.343 & 0.5 &
-0.333 \\-0.125 & 0.708 & -0.333 & 0.708 & -0.958 &
-1.167 & 0.083 & 0.5 & 0.718 & -0.125 \\0.083 &
-0.125 & -0.125 & -0.125 & 0.292 & 0.083 & 0.292
& -0.333 & -0.125 & 0.093\end{bmatrix}\]
Your Tasks
- Specify all model components of the linear mixed model, including
the expected values and the variance-covariance matrix of the random
effects.
Your Solution
- Specify the model formula
- Name all model components
- Put all information from the data into the model components
- Specify expected values and variance-covariance matrix for all
random effects in the model
- Setup mixed model equations
- Compute solutions of mixed model equations
Latest Changes: 2022-12-16 07:22:12 (pvr)
LS0tCnRpdGxlOiBMaXZlc3RvY2sgQnJlZWRpbmcgYW5kIEdlbm9taWNzIC0gTm90ZWJvb2sgMTAKYXV0aG9yOiBQZXRlciB2b24gUm9ocgpkYXRlOiAnMjAyMi0xMi0wOScKb3V0cHV0OiBodG1sX25vdGVib29rCnBhcmFtczoKICBkb2N0eXBlOgogICAgbGFiZWw6IERvY3VtZW50IFR5cGUKICAgIHZhbHVlOiBzb2x1dGlvbgogICAgY2hvaWNlczoKICAgIC0gZXhlcmNpc2UKICAgIC0gc29sdXRpb24KICAgIC0gbm90ZWJvb2sKICBpc29ubGluZToKICAgIGxhYmVsOiBPbmxpbmUgKHkvbikKICAgIHZhbHVlOiB0cnVlCiAgICBjaG9pY2VzOgogICAgLSB0cnVlCiAgICAtIGZhbHNlCi0tLQoKCgpgYGB7ciBzZXR1cCwgaW5jbHVkZT1GQUxTRX0Ka25pdHI6Om9wdHNfY2h1bmskc2V0KGVjaG8gPSBUUlVFKQpgYGAKCgojIyBQcm9ibGVtIDE6IE1hcmtlciBFZmZlY3QgTW9kZWwKCmBgYHtyIGRhdGFmbGVtc25wb2JzLCBlY2hvPUZBTFNFLCBtZXNzYWdlPUZBTFNFfQpsaWJyYXJ5KGRwbHlyKQojIyMgIyBmaXggdGhlIG51bWJlciBvZiBhbmltYWxzCm5fbnJfYW5pbWFsIDwtIDEwCiMjIyAjIGludGVyY2VwdApuX2ludGVyX2NlcHQgPC0gMTUwCiMjIyAjIHJlc2lkdWFsIHN0YW5kYXJkIGRldmlhdGlvbgpuX3Jlc19zZCA8LSA5LjMKIyMjICMgdmVjdG9yIG9mIGdlbm90eXBlIHZhbHVlIGNvZWZmaWNpZW50cwp2ZWNfZ2Vub192YWx1ZV9jb2VmZiA8LSBjKC0xLDAsMSkKIyMjICMgc2FtcGxlIGdlbm90eXBlcyBvZiB1bmxpbmtlZCBTTlAgcmFuZG9tbHkKc2V0LnNlZWQoNTQzMikKIyMjICMgZml4IGFsbGVsZSBmcmVxdWVuY3kgb2YgcG9zaXRpdmUgYWxsZWxlCm5fcHJvYl9zbnBzIDwtIC40NQojIyMgIyBnZW5vdHlwaWMgdmFsdWVzIAp2ZWNfZ2Vub192YWwgPC0gYygxNy45LCAzLjMpCm5fbnJfc25wIDwtIGxlbmd0aCh2ZWNfZ2Vub192YWwpCiMjIyAjIHB1dCB0b2dldGhlciB0aGUgZ2Vub3R5cGVzIGludG8gYSBtYXRyaXgKbWF0X2dlbm9fc25wIDwtIG1hdHJpeChjKHNhbXBsZSh2ZWNfZ2Vub192YWx1ZV9jb2VmZiwgbl9ucl9hbmltYWwsIHByb2IgPSBjKCgxLW5fcHJvYl9zbnBzKV4yLCAKICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgIDIqKDEtbl9wcm9iX3NucHMpKm5fcHJvYl9zbnBzLCAKICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgIG5fcHJvYl9zbnBzXjIpLCAKICAgICAgICAgICAgICAgICAgICAgICByZXBsYWNlID0gVFJVRSksCiAgICAgICAgICAgICAgICAgICAgICAgc2FtcGxlKHZlY19nZW5vX3ZhbHVlX2NvZWZmLCBuX25yX2FuaW1hbCwgcHJvYiA9IGMobl9wcm9iX3NucHNeMiwgCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAyKigxLW5fcHJvYl9zbnBzKSpuX3Byb2Jfc25wcywgCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAoMS1uX3Byb2Jfc25wcyleMiksIAogICAgICAgICAgICAgICAgICAgICAgIHJlcGxhY2UgPSBUUlVFKSksCiAgICAgICAgICAgICAgICAgICAgICAgbnJvdyA9IG5fbnJfc25wKQptYXRfb2JzX3kgPC0gbl9pbnRlcl9jZXB0ICsgY3Jvc3Nwcm9kKG1hdF9nZW5vX3NucCwgdmVjX2dlbm9fdmFsKSArIHJub3JtKG4gPSBuX25yX2FuaW1hbCwgbWVhbiA9IDAsIHNkID0gbl9yZXNfc2QpCiMjIyAjIGNvbWJpbmUgU05QIGdlbm90eXBlcyBpbnRvIGEgdGliYmxlCmdlbm9fY29kZSA8LSB0aWJibGU6OnRpYmJsZShgU05QIEFgID0gbWF0X2dlbm9fc25wWzEsXSwKICAgICAgICAgICAgICAgICAgICAgICAgICAgIGBTTlAgQmAgPSBtYXRfZ2Vub19zbnBbMixdKQoKIyMjICMgYWRkIHRoZSBkYXRhCm1hdF9vYnNfeV9yb3VuZGVkIDwtIHJvdW5kKG1hdF9vYnNfeSwgZGlnaXRzID0gMCkKdGJsX29icyA8LSB0aWJibGU6OnRpYmJsZShPYnNlcnZhdGlvbiA9IG1hdF9vYnNfeV9yb3VuZGVkWywxXSkKZ2Vub19jb2RlICU+JSBiaW5kX2NvbHModGJsX29icykgLT4gdGJsX2FsbF9kYXRhCiMjIyAjIGFkZCBhbmltYWwgaWRzCnRibF9hbGxfZGF0YSA8LSBiaW5kX2NvbHMoQW5pbWFsID0gYygxOm5fbnJfYW5pbWFsKSx0YmxfYWxsX2RhdGEpCiMjIyAjIHdyaXRlIGRhdGEgdG8gZmlsZQojIHNfZGF0YV9wYXRoIDwtIGZpbGUucGF0aChoZXJlOjpoZXJlKCksICJkb2NzIiwgImRhdGEiLCAiZ2Vub19kYXRhLmNzdiIpCiMgcmVhZHI6OndyaXRlX2Nzdih0YmxfYWxsX2RhdGEsIGZpbGUgPSBzX2RhdGFfcGF0aCkKIyBkYXRhIHVybApzX2RhdGFfdXJsX3BhdGggPC0gImh0dHBzOi8vY2hhcmxvdHRlLW5ncy5naXRodWIuaW8vbGJnZnMyMDIyL2RhdGEvZ2Vub19kYXRhLmNzdiIKYGBgCgpXZSBhcmUgZ2l2ZW4gdGhlIGRhdGFzZXQgdGhhdCBpcyBzaG93biBpbiB0aGUgdGFibGUgYmVsb3cuIFRoaXMgZGF0YXNldCBjb250YWlucyBnZW50eXBpbmcgcmVzdWx0cyBvZiBgciBuX25yX2FuaW1hbGAgZm9yIGByIG5fbnJfc25wYCBTTlAgbG9jaS4KCmBgYHtyIHNob3dkYXRhZXgxMywgZWNobz1GQUxTRX0Ka25pdHI6OmthYmxlKHRibF9hbGxfZGF0YSwKICAgICAgICAgICAgIGJvb2t0YWJzID0gVFJVRSwKICAgICAgICAgICAgIGxvbmd0YWJsZSA9IFRSVUUsCiMgICAgICAgICAgICAgY2FwdGlvbiA9ICJBbmltYWxzIFdpdGggVHdvIFNOUCBMb2NpIEEgYW5kIEIgQWZmZWN0aW5nIEEgUXVhbnRpdGF0aXZlIFRyYWl0IiwKICAgICAgICAgICAgIGVzY2FwZSA9IEZBTFNFKQoKYGBgCgpUaGUgYWJvdmUgZGF0YSBjYW4gYmUgcmVhZCBmcm9tOgoKYGBge3IsIGVjaG89RkFMU0V9CmNhdChzX2RhdGFfdXJsX3BhdGgsICJcbiIpCmBgYAoKCiMjIyBZb3VyIFRhc2sKKiBUaGUgZ29hbCBvZiB0aGlzIHByb2JsZW0gaXMgdG8gZXN0aW1hdGUgU05QIG1hcmtlciBlZmZlY3RzIHVzaW5nIGEgYG1hcmtlciBlZmZlY3QgbW9kZWxgLiBCZWNhdXNlIHdlIGhhdmUganVzdCBgciBuX25yX3NucGAgU05QIGxvY2ksIHlvdSBjYW4gdXNlIGEgZml4ZWQgZWZmZWN0cyBsaW5lYXIgbW9kZWwgd2l0aCB0aGUgYHIgbl9ucl9zbnBgIGxvY2kgYXMgZml4ZWQgZWZmZWN0cy4gRnVydGhlcm1vcmUgeW91IGNhbiBhbHNvIGluY2x1ZGUgYSBmaXhlZCBpbnRlcmNlcHQgaW50byB0aGUgbW9kZWwuCiogU3BlY2lmeSBhbGwgdGhlIG1vZGVsIGNvbXBvbmVudHMgaW5jbHVkaW5nIHRoZSB2ZWN0b3Igb2Ygb2JzZXJ2YXRpb25zLCB0aGUgZGVzaWduIG1hdHJpeCAkWCQsIHRoZSB2ZWN0b3Igb2YgdW5rbm93bnMgYW5kIHRoZSB2ZWN0b3Igb2YgcmVzaWR1YWxzLiAKKiBZb3UgY2FuIHVzZSB0aGUgUi1mdW5jdGlvbiBgbG0oKWAgdG8gZ2V0IHRoZSBzb2x1dGlvbnMgZm9yIGVzdGltYXRlcyBvZiB0aGUgdW5rbm93biBTTlAgZWZmZWN0cy4KCgojIyMgWW91ciBTb2x1dGlvbgoKKiBTZXQgdXAgdGhlIHJlZ3Jlc3Npb24gbW9kZWwKKiBVc2UgbG0oKSB0byBnZXQgdGhlIHJlZ3Jlc3Npb24gY29lZmZpY2llbnRzIGFzIG1hcmtlciBlZmZlY3RzCgoKCgoKIyMgUHJvYmxlbSAyOiBCcmVlZGluZyBWYWx1ZSBNb2RlbApVc2UgdGhlIHNhbWUgZGF0YSBhcyBpbiBQcm9ibGVtIDEgdG8gZXN0aW1hdGUgZ2Vub21pYyBicmVlZGluZyB2YWx1ZXMgdXNpbmcgYSBgYnJlZWRpbmcgdmFsdWUgbW9kZWxgLgoKCiMjIyBIaW50cwoqIFRoZSBvbmx5IGZpeGVkIGVmZmVjdCBpbiB0aGlzIG1vZGVsIGlzIHRoZSBtZWFuICRcbXUkIHdoaWNoIGlzIHRoZSBzYW1lIGZvciBhbGwgb2JzZXJ2YXRpb25zLgoqIFlvdSBjYW4gdXNlIHRoZSBmb2xsb3dpbmcgZnVuY3Rpb24gdG8gY29tcHV0ZSB0aGUgZ2Vub21pYyByZWxhdGlvbnNoaXAgbWF0cml4CgpgYGB7ciwgZWNobz1UUlVFfQojJyBDb21wdXRlIGdlbm9taWMgcmVsYXRpb25zaGlwIG1hdHJpeCBiYXNlZCBvbiBkYXRhIG1hdHJpeApjb21wdXRlTWF0R3JtIDwtIGZ1bmN0aW9uKHBtYXREYXRhKSB7CiAgbWF0RGF0YSA8LSBwbWF0RGF0YQogICMgY2hlY2sgdGhlIGNvZGluZywgaWYgbWF0RGF0YSBpcyAtMSwgMCwgMSBjb2RlZCwgdGhlbiBhZGQgMSB0byBnZXQgdG8gMCwgMSwgMiBjb2RpbmcKICBpZiAobWluKG1hdERhdGEpIDwgMCkgbWF0RGF0YSA8LSBtYXREYXRhICsgMQogICMgQWxsZWxlIGZyZXF1ZW5jaWVzLCBjb2x1bW4gdmVjdG9yIG9mIFAgYW5kIHN1bSBvZiBmcmVxdWVuY3kgcHJvZHVjdHMKICBmcmVxIDwtIGFwcGx5KG1hdERhdGEsIDIsIG1lYW4pIC8gMgogIFAgPC0gMiAqIChmcmVxIC0gMC41KQogIHN1bXBxIDwtIHN1bShmcmVxKigxLWZyZXEpKQogICMgQ2hhbmdpbmcgdGhlIGNvZGluZyBmcm9tICgwLDEsMikgdG8gKC0xLDAsMSkgYW5kIHN1YnRyYWN0IG1hdHJpeCBQCiAgWiA8LSBtYXREYXRhIC0gMSAtIG1hdHJpeChQLCBucm93ID0gbnJvdyhtYXREYXRhKSwgCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgbmNvbCA9IG5jb2wobWF0RGF0YSksIAogICAgICAgICAgICAgICAgICAgICAgICAgICAgIGJ5cm93ID0gVFJVRSkKICAjIFolKiVadCBpcyByZXBsYWNlZCBieSB0Y3Jvc3Nwcm9kKFopCiAgcmV0dXJuKHRjcm9zc3Byb2QoWikvKDIqc3VtcHEpKQp9Cm1hdEcgPC1jb21wdXRlTWF0R3JtKHBtYXREYXRhID0gdChtYXRfZ2Vub19zbnApKQptYXRHX3N0YXIgPC0gbWF0RyArIDAuMDEgKiBkaWFnKG5yb3cgPSBucm93KG1hdEcpKQpuX21pbl9laWdfbWF0R19zdGFydCA8LSBtaW4oZWlnZW4obWF0R19zdGFyLCBvbmx5LnZhbHVlcyA9IFRSVUUpJHZhbHVlcykKaWYgKG5fbWluX2VpZ19tYXRHX3N0YXJ0IDwgc3FydCguTWFjaGluZSRkb3VibGUuZXBzKSkKICBzdG9wKCIgKioqIEdlbm9taWMgcmVsYXRpb25zaGlwIG1hdHJpeCBzaW5ndWxhciB3aXRoIHNtYWxsZXN0IGVpZ2VudmFsdWU6ICIsIAogICAgICAgbl9taW5fZWlnX21hdEdfc3RhcnQpCmBgYAoKKiBUaGUgcmVzdWx0aW5nIGdlbm9taWMgcmVsYXRpb25zaGlwIG1hdHJpeCBpcyBnaXZlbiBieQoKYGBge3Igc2hvdy1nZW5vbWljLXJlbHRpb25zaGlwLW1hdHJpeCwgZWNobz1GQUxTRSwgcmVzdWx0cz0nYXNpcyd9CmNhdChwYXN0ZShybWRoZWxwOjpibWF0cml4KHBtYXQgPSByb3VuZChtYXRHX3N0YXIsIGRpZ2l0cyA9IDMpLCBwc19uYW1lID0gJ0cnLCBwc19lbnYgPSAnJCQnKSwgY29sbGFwc2UgPSAnXG4nKSwgJ1xuJykKYGBgCgojIyMgWW91ciBUYXNrcwoqIFNwZWNpZnkgYWxsIG1vZGVsIGNvbXBvbmVudHMgb2YgdGhlIGxpbmVhciBtaXhlZCBtb2RlbCwgaW5jbHVkaW5nIHRoZSBleHBlY3RlZCB2YWx1ZXMgYW5kIHRoZSB2YXJpYW5jZS1jb3ZhcmlhbmNlIG1hdHJpeCBvZiB0aGUgcmFuZG9tIGVmZmVjdHMuCgoKIyMjIFlvdXIgU29sdXRpb24KCiogU3BlY2lmeSB0aGUgbW9kZWwgZm9ybXVsYQoqIE5hbWUgYWxsIG1vZGVsIGNvbXBvbmVudHMKKiBQdXQgYWxsIGluZm9ybWF0aW9uIGZyb20gdGhlIGRhdGEgaW50byB0aGUgbW9kZWwgY29tcG9uZW50cwoqIFNwZWNpZnkgZXhwZWN0ZWQgdmFsdWVzIGFuZCB2YXJpYW5jZS1jb3ZhcmlhbmNlIG1hdHJpeCBmb3IgYWxsIHJhbmRvbSBlZmZlY3RzIGluIHRoZSBtb2RlbAoqIFNldHVwIG1peGVkIG1vZGVsIGVxdWF0aW9ucwoqIENvbXB1dGUgc29sdXRpb25zIG9mIG1peGVkIG1vZGVsIGVxdWF0aW9ucwoKCgoKCmBgYHtyLCBlY2hvPUZBTFNFLCByZXN1bHRzPSdhc2lzJ30KY2F0KCdcbi0tLVxuXG4gX0xhdGVzdCBDaGFuZ2VzOiAnLCBmb3JtYXQoU3lzLnRpbWUoKSwgJyVZLSVtLSVkICVIOiVNOiVTJyksICcgKCcsIFN5cy5pbmZvKClbJ3VzZXInXSwgJylfXG4nLCBzZXAgPSAnJykKYGBgCiAK