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.

Animal SNP A SNP B Observation
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