├── .gitignore ├── .gitattributes ├── Alternative Heritability Measures ├── SAS │ ├── MACRO H2_Cullis.sas │ ├── MACRO H2_Oakey.sas │ ├── MACRO H2_Piepho.sas │ ├── MACRO H2_BLUP_BLUE.sas │ ├── README.md │ ├── example H2_Oakey.sas │ ├── example H2_Cullis.sas │ ├── example H2_sim.sas │ ├── example H2_BLUP_BLUE.sas │ ├── example H2_Piepho.sas │ ├── MACROS getC22g getGFD getGamma.sas │ └── MACRO H2_R_Simulated.sas ├── lme4 │ ├── README.md │ ├── H2 Piepho.R │ ├── H2 Reg & H2 SumDiv.R │ ├── H2 Oakey.R │ ├── H2 Cullis.R │ └── H2 Simulated.R ├── sommer │ ├── README.md │ ├── H2 Cullis.R │ └── H2 Oakey.R ├── ASReml-R │ ├── README.md │ ├── H2 Cullis.R │ ├── H2 Piepho.R │ ├── H2 Oakey.R │ ├── H2 Reg & H2 SumDiv.R │ ├── .Rhistory │ ├── H2 Delta (BLUP).R │ └── H2 Delta (BLUE).R └── README.md ├── Heritability.Rproj └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | -------------------------------------------------------------------------------- /Alternative Heritability Measures/SAS/MACRO H2_Cullis.sas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PaulSchmidtGit/Heritability/HEAD/Alternative Heritability Measures/SAS/MACRO H2_Cullis.sas -------------------------------------------------------------------------------- /Alternative Heritability Measures/SAS/MACRO H2_Oakey.sas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PaulSchmidtGit/Heritability/HEAD/Alternative Heritability Measures/SAS/MACRO H2_Oakey.sas -------------------------------------------------------------------------------- /Alternative Heritability Measures/SAS/MACRO H2_Piepho.sas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PaulSchmidtGit/Heritability/HEAD/Alternative Heritability Measures/SAS/MACRO H2_Piepho.sas -------------------------------------------------------------------------------- /Alternative Heritability Measures/SAS/MACRO H2_BLUP_BLUE.sas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PaulSchmidtGit/Heritability/HEAD/Alternative Heritability Measures/SAS/MACRO H2_BLUP_BLUE.sas -------------------------------------------------------------------------------- /Heritability.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | -------------------------------------------------------------------------------- /Alternative Heritability Measures/lme4/README.md: -------------------------------------------------------------------------------- 1 | ## Alternative Estimation Methods for H² on Entry-Mean Basis in R (via `lme4`) 2 | For information on how to use these codes, plase go to the [main page](https://github.com/PaulSchmidtGit/Heritability/tree/master/Alternative%20Heritability%20Measures) -------------------------------------------------------------------------------- /Alternative Heritability Measures/sommer/README.md: -------------------------------------------------------------------------------- 1 | ## Alternative Estimation Methods for H² on Entry-Mean Basis in R (via `sommer`) 2 | For information on how to use these codes, plase go to the [main page](https://github.com/PaulSchmidtGit/Heritability/tree/master/Alternative%20Heritability%20Measures) 3 | 4 | 5 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Heritability in Plant Breeding 2 | This GitHub respository contains `R` and `SAS` codes for a number of methods for heritability estimation in plant breeding and thus mostly *heritability on an entry-mean basis*. Its aim is to provide helpful examples for researchers and practicioners in the field of plant breeding or general cultivar evaluation trials. 3 | 4 | **Please navigate the content via clicking on the folders above.** 5 | 6 | It is work in progress and will be updated from time to time. 7 | 8 | #### Contact 9 | Please find my [main github account here](https://github.com/SchmidtPaul). 10 | 11 | 12 | 13 | -------------------------------------------------------------------------------- /Alternative Heritability Measures/ASReml-R/README.md: -------------------------------------------------------------------------------- 1 | ## Alternative Estimation Methods for H² on Entry-Mean Basis in ASReml-R 2 | For information on how to use these codes, plase go to the [main page](https://github.com/PaulSchmidtGit/Heritability/tree/master/Alternative%20Heritability%20Measures) 3 | 4 | 5 | 6 |

7 | 8 | 9 | 10 |

11 | 12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /Alternative Heritability Measures/ASReml-R/H2 Cullis.R: -------------------------------------------------------------------------------- 1 | rm(list = ls()) 2 | ####################### 3 | # Import example data # 4 | ####################### 5 | library(agridat) 6 | dat <- john.alpha 7 | 8 | ############# 9 | # Fit model # 10 | ############# 11 | library(asreml) 12 | # Genotype as random effect 13 | g.ran <- asreml(fixed = yield ~ rep, 14 | random= ~ gen + rep:block, 15 | data=dat) 16 | 17 | ########################## 18 | # Handle model estimates # 19 | ########################## 20 | # Genetic variance component 21 | vc.g <- summary(g.ran)$varcomp['gen!gen.var','component'] 22 | vc.g #0.142902 23 | 24 | # Mean variance of a difference of two genotypic BLUPs 25 | vdBLUP.mat <- predict(g.ran, classify="gen", only="gen", sed=TRUE)$pred$sed^2 # obtain squared s.e.d. matrix 26 | vdBLUP.avg <- mean(vdBLUP.mat[upper.tri(vdBLUP.mat, diag=FALSE)]) # take mean of upper triangle 27 | vdBLUP.avg #0.05455038 28 | 29 | ############# 30 | # H2 Cullis # 31 | ############# 32 | H2Cullis <- 1 - (vdBLUP.avg / 2 / vc.g) 33 | H2Cullis #0.8091336 34 | -------------------------------------------------------------------------------- /Alternative Heritability Measures/lme4/H2 Piepho.R: -------------------------------------------------------------------------------- 1 | library(agridat) 2 | library(emmeans) 3 | library(lme4) 4 | library(tidyverse) 5 | 6 | # get example data -------------------------------------------------------- 7 | dat <- agridat::john.alpha 8 | 9 | 10 | # fit model --------------------------------------------------------------- 11 | # random genotype effect 12 | g_ran <- lmer(data = dat, 13 | formula = yield ~ rep + (1|gen) + (1|rep:block)) 14 | 15 | # fixed genotype effect 16 | g_fix <- lmer(data = dat, 17 | formula = yield ~ rep + gen + (1|rep:block)) 18 | 19 | 20 | # handle model estimates -------------------------------------------------- 21 | # genotypic variance component 22 | vc.g <- g_ran %>% 23 | VarCorr %>% 24 | as_tibble %>% 25 | filter(grp=="gen") %>% 26 | pull(vcov) # 0.1429021 27 | 28 | # mean variance of a difference between genotypes 29 | vdBLUE.avg <- g_fix %>% 30 | emmeans(pairwise ~ gen) %>% 31 | pluck("contrasts") %>% 32 | as_tibble %>% 33 | mutate(Var=SE^2) %>% 34 | pull(Var) %>% 35 | mean # 0.07295899 36 | 37 | 38 | # H2 Piepho --------------------------------------------------------------- 39 | H2.p <- vc.g/(vc.g + vdBLUE.avg/2) 40 | H2.p # 0.7966375 -------------------------------------------------------------------------------- /Alternative Heritability Measures/ASReml-R/H2 Piepho.R: -------------------------------------------------------------------------------- 1 | rm(list = ls()) 2 | ####################### 3 | # Import example data # 4 | ####################### 5 | library(agridat) 6 | dat <- john.alpha 7 | 8 | ############## 9 | # Fit models # 10 | ############## 11 | library(asreml) 12 | # Genotype as random effect 13 | g.ran <- asreml(fixed = yield ~ rep, 14 | random= ~ gen + rep:block, 15 | data=dat) 16 | # Genotype as fixed effect 17 | g.fix <- asreml(fixed = yield ~ gen + rep, 18 | random= ~ rep:block, 19 | data=dat) 20 | 21 | ########################## 22 | # Handle model estimates # 23 | ########################## 24 | # Genetic variance component 25 | vc.g <- summary(g.ran)$varcomp['gen!gen.var','component'] 26 | vc.g #0.142902 27 | 28 | # Mean variance of a difference of two genotypic BLUEs 29 | vdBLUE.mat <- predict(g.fix, classify="gen", sed=TRUE)$pred$sed^2 # obtain squared s.e.d. matrix 30 | vdBLUE.avg <- mean(vdBLUE.mat[upper.tri(vdBLUE.mat, diag=FALSE)]) # take mean of upper triangle 31 | vdBLUE.avg #0.07010875 32 | 33 | ############# 34 | # H2 Piepho # 35 | ############# 36 | H2.p <- vc.g/(vc.g + vdBLUE.avg/2) 37 | H2.p #0.803017 38 | 39 | 40 | 41 | -------------------------------------------------------------------------------- /Alternative Heritability Measures/sommer/H2 Cullis.R: -------------------------------------------------------------------------------- 1 | library(agridat) 2 | library(psych) 3 | library(sommer) 4 | library(tidyverse) 5 | 6 | 7 | # get example data -------------------------------------------------------- 8 | dat <- agridat::john.alpha 9 | 10 | 11 | # fit model --------------------------------------------------------------- 12 | # random genotype effect 13 | g.ran <- mmer(fixed = yield ~ rep, 14 | random = ~ gen + rep:block, 15 | data = dat) 16 | 17 | # handle model estimates -------------------------------------------------- 18 | vc_g <- g.ran %>% pluck("sigma") %>% pluck("gen") %>% as.numeric # genetic variance component 19 | n_g <- g.ran %>% pluck("U") %>% pluck("gen") %>% pluck("yield") %>% length # number of genotypes 20 | C22_g <- g.ran %>% pluck("PevU") %>% pluck("gen") %>% pluck("yield") # Prediction error variance matrix for genotypic BLUPs 21 | trC22_g <- psych::tr(as.matrix(C22_g)) # trace 22 | vdBLUP_g <- 2/n_g * (trC22_g - (sum(C22_g)-trC22_g) / (n_g-1)) # Mean variance of a difference between genotypic BLUPs 23 | 24 | 25 | # H2 Cullis --------------------------------------------------------------- 26 | H2Cullis <- 1-(vdBLUP_g / 2 / vc_g) 27 | H2Cullis #0.8091336 -------------------------------------------------------------------------------- /Alternative Heritability Measures/ASReml-R/H2 Oakey.R: -------------------------------------------------------------------------------- 1 | rm(list = ls()) 2 | ####################### 3 | # Import example data # 4 | ####################### 5 | library(agridat) 6 | dat <- john.alpha 7 | 8 | ############# 9 | # Fit model # 10 | ############# 11 | library(asreml) 12 | # Genotype as random effect 13 | g.ran <- asreml(fixed = yield ~ rep, 14 | random= ~ gen + rep:block, 15 | data=dat) 16 | 17 | ########################## 18 | # Handle model estimates # 19 | ########################## 20 | n.g <- as.numeric(g.ran$noeff["gen"]) # number of genotypes 21 | vc.g <- summary(g.ran)$varcomp['gen!gen.var','component'] # genetic variance component 22 | G.g <- diag(1,n.g)*vc.g # note that this is manually created for simple diag structre 23 | C22.g <- predict(g.ran, classify="gen", only="gen", vcov=TRUE)$pred$vcov 24 | M <- diag(n.g)-(solve(G.g)%*%C22.g) # [see p. 813 bottom left in Oakey (2006)] 25 | eM <- eigen(M) # obtain eigenvalues 26 | 27 | ############ 28 | # H2 Oakey # 29 | ############ 30 | # main method [see eq. (7) in Oakey (2006)] 31 | H2Oakey <- sum(eM$values)/(n.g-1) 32 | H2Oakey # 0.8091336 33 | 34 | library(psych) # to compute trace of a matrix 35 | # approximate method [see p. 813 top right in Oakey (2006)] 36 | H2Oakey.approx <- 1 - tr( solve(G.g)%*%C22.g / n.g ) 37 | H2Oakey.approx # 0.7754197 38 | 39 | -------------------------------------------------------------------------------- /Alternative Heritability Measures/sommer/H2 Oakey.R: -------------------------------------------------------------------------------- 1 | library(agridat) 2 | library(psych) 3 | library(sommer) 4 | library(tidyverse) 5 | 6 | 7 | # get example data -------------------------------------------------------- 8 | dat <- agridat::john.alpha 9 | 10 | 11 | # fit model --------------------------------------------------------------- 12 | # random genotype effect 13 | g.ran <- mmer(fixed = yield ~ rep, 14 | random = ~ gen + rep:block, 15 | data = dat) 16 | 17 | 18 | # handle model estimates -------------------------------------------------- 19 | vc_g <- g.ran %>% pluck("sigma") %>% pluck("gen") %>% as.numeric # genetic variance component 20 | n_g <- g.ran %>% pluck("U") %>% pluck("gen") %>% pluck("yield") %>% length # number of genotypes 21 | G_g <- diag(n_g)*vc_g # subset of G regarding genotypic effects = I * vc.g 22 | C22_g <- g.ran %>% pluck("PevU") %>% pluck("gen") %>% pluck("yield") # Prediction error variance matrix for genotypic BLUPs 23 | 24 | ED <- diag(n_g) - (solve(G_g) %*% C22_g) # [see p. 813 bottom left in Oakey (2006)] 25 | eM <- ED %>% eigen # obtain eigenvalues 26 | 27 | 28 | # H2 Oakey ---------------------------------------------------------------- 29 | # main method [see eq. (7) in Oakey (2006)] 30 | H2Oakey <- sum(eM$values)/(n_g-1) 31 | H2Oakey # 0.8091336 32 | 33 | # approximate method [see p. 813 top right in Oakey (2006)] 34 | H2Oakey_approx <- 1 - psych::tr( as.matrix(solve(G_g) %*% C22_g / n_g ) ) 35 | H2Oakey_approx # 0.7754197 36 | -------------------------------------------------------------------------------- /Alternative Heritability Measures/ASReml-R/H2 Reg & H2 SumDiv.R: -------------------------------------------------------------------------------- 1 | rm(list = ls()) 2 | ####################### 3 | # Import example data # 4 | ####################### 5 | library(agridat) 6 | dat <- john.alpha 7 | 8 | ############## 9 | # Fit models # 10 | ############## 11 | library(asreml) 12 | 13 | dat$Mu <- 1 #Create pseudo intercept to obtain estimate for Mu 14 | 15 | # Genotype as random effect 16 | g.ran <- asreml(fixed = yield ~ -1 + Mu + rep, 17 | random= ~ gen + rep:block, 18 | data=dat, 19 | ran.order = "user") #Force "gen" as first random effect in asreml object - makes BLUP extraction easier 20 | # Genotype as fixed effect 21 | g.fix <- asreml(fixed = yield ~ -1 + Mu + gen + rep, 22 | random= ~ rep:block, 23 | data=dat) 24 | 25 | ########################## 26 | # Handle model estimates # 27 | ########################## 28 | # gentoypic BLUEs 29 | BLUEs <- predict(g.fix, classify="gen")$pred$pvals[,c('gen','predicted.value')] 30 | 31 | # gentoypic BLUPS 32 | BLUPs <- predict(g.ran, classify="gen", only="gen")$pred$pvals[,c('gen','predicted.value')] 33 | 34 | # Overall mean in g.ran 35 | Mu.ran <- predict(g.ran, classify="Mu")$pred$pvals$predicted.value 36 | Mu.ran #4.479517 37 | 38 | # Combine BLUPs and BLUEs, obtain scaled BLUEs 39 | Gpreds <- data.frame(gen = BLUEs[,1], 40 | BLUP = BLUPs[,2], 41 | BLUE = BLUEs[,2], 42 | scaled.BLUE = BLUEs[,2]-Mu.ran) 43 | 44 | ################ 45 | # H2 BLUP~BLUE # 46 | ################ 47 | H2reg <- lm(data = Gpreds, 48 | formula = BLUP ~ 0 + scaled.BLUE)$coefficients 49 | H2reg #0.8178116 50 | 51 | ############# 52 | # H2 sumdiv # 53 | ############# 54 | H2sumdiv <- sum(abs(Gpreds$BLUP))/sum(abs(Gpreds$scaled.BLUE)) 55 | H2sumdiv #0.8205183 56 | -------------------------------------------------------------------------------- /Alternative Heritability Measures/lme4/H2 Reg & H2 SumDiv.R: -------------------------------------------------------------------------------- 1 | library(agridat) 2 | library(emmeans) 3 | library(lme4) 4 | library(tidyverse) 5 | 6 | 7 | # get example data -------------------------------------------------------- 8 | dat <- agridat::john.alpha %>% 9 | mutate(Mu = 1) # Create dummy column for pseudo intercept in order to obtain estimate for Mu 10 | 11 | 12 | # fit model --------------------------------------------------------------- 13 | # random genotype effect 14 | g_ran <- lmer(data = dat, 15 | formula = yield ~ 0 + Mu + rep + (1|gen) + (1|rep:block)) # Default intercept set to 0, pseudo intercept Mu instead 16 | 17 | # fixed genotype effect 18 | g_fix <- lmer(data = dat, 19 | formula = yield ~ rep + gen + (1|rep:block)) 20 | 21 | 22 | # handle model estimates -------------------------------------------------- 23 | # genotypic BLUPs 24 | g_BLUPs <- g_ran %>% 25 | ranef %>% as_tibble %>% 26 | rename(BLUP=condval) %>% 27 | filter(grpvar=="gen") %>% 28 | mutate(gen = grp %>% as.character %>% as.factor) %>% 29 | select(gen, BLUP) 30 | 31 | # estimated marginal means (a.k.a. adjusted means) based on genotypic BLUEs 32 | g_EMMs <- g_fix %>% 33 | emmeans("gen") %>% 34 | as_tibble %>% 35 | select(gen, emmean) 36 | 37 | # Overall mean in g_ran 38 | Mu_ran <- g_ran %>% emmeans("Mu") %>% as_tibble %>% pull(emmean) 39 | 40 | # Combine BLUPs and emmeans, compute scaled emmeans 41 | Gpreds <- left_join(g_EMMs, g_BLUPs, by="gen") %>% 42 | mutate(scaled_emmean = emmean - Mu_ran) 43 | 44 | 45 | # H2 BLUP~BLUE ------------------------------------------------------------ 46 | H2reg <- lm(data = Gpreds, 47 | formula = BLUP ~ 0 + scaled_emmean) %>% pluck("coefficients") 48 | H2reg #0.8178116 49 | 50 | 51 | # H2 sumdiv --------------------------------------------------------------- 52 | H2sumdiv <- sum(abs(Gpreds$BLUP)) / sum(abs(Gpreds$scaled_emmean)) 53 | H2sumdiv #0.8205183 -------------------------------------------------------------------------------- /Alternative Heritability Measures/README.md: -------------------------------------------------------------------------------- 1 | # Alternative Estimation Methods for H² on Entry-Mean Basis 2 | 3 | There are several alternative estimation methods for broad-sense and narrow-sense heritability on an entry-mean basis. Additionally, we proposed heritability on an entry-difference basis. Please see our articles for more information: 4 | 5 | * Schmidt, P.; Hartung, J.; Rath, J.; Piepho, H.-P. (2019): **Estimating broad-sense heritability with unbalanced data from agricultural cultivar trials**. In Crop Science 59 (2), pp. 525–536. DOI: [10.2135/cropsci2018.06.0376](https://doi.org/10.2135/cropsci2018.06.0376). 6 | * Schmidt, P., Hartung, J., Bennewitz, J., & Piepho, H. P. (2019). **Heritability in Plant Breeding on a Genotype-Difference Basis**. Genetics, genetics-302134. DOI: [10.1534/genetics.119.302134](https://doi.org/10.1534/genetics.119.302134). 7 | 8 | Above, you will find different folders containing example code for different mixed model packages: 9 | 10 | * `asreml()` of the R-package [ASReml-R Version 3.0](https://www.vsni.co.uk/software/asreml-r/) 11 | * `mmer2()` of the R-package [sommer](https://cran.r-project.org/web/packages/sommer/index.html) 12 | * `lmer()` of the R-package [lme4](http://lme4.r-forge.r-project.org/) 13 | * `PROC MIXED` in [SAS](https://www.sas.com/en_us/home.html) 14 | 15 | For all R packages you will find example analyses that you can copy-paste into R and run immediately (given all required packages are installed). 16 | 17 | For SAS it works similarly, yet you will see that the example analyses make use of SAS `%MACROs`. These macros are also provided in the SAS folders. You do not need to copy-paste or download the macros in order to run the example analyses, since they are included automatically via their URL and a `proc http` command at the top of each code. 18 | 19 | **IMPORTANT: Keep in mind that these are example codes which means that they do not necessarily apply to other models/settings. Their purpose is merely to exemplarily demonstrate and thus function as a starting point to be modified for other analyses.** -------------------------------------------------------------------------------- /Alternative Heritability Measures/SAS/README.md: -------------------------------------------------------------------------------- 1 | ## Alternative Estimation Methods for H² on Entry-Mean Basis in SAS 2 | For each method, you will find 3 | * a `%MACRO` and 4 | * an example with where this `%MACRO` is applied to a simple dataset. 5 | 6 | You can simply copy-paste the example code into SAS and run it (given you are connected to the internet). This works, because the respective `%MACRO` is run directly from this github page via a `proc http` command at the beginning of each example. Everything else (i.e. dataset, modelling procedure etc.) is provided in the example code. 7 | 8 | #### Note on additional, supporting `%MACRO`s 9 | Due to the limitations of SAS' Output Delivery System, some of the estimated tables/matrices you can obtain from `PROC MIXED` need further processing in order to obtain the desired estimate. Specifically the estimated variance-covariance matrices of the random (genotype) effects obtained via `G=` and the estimated variance-covariance matrix of the genotype BLUPs contained in the `MMEqSol=` need to be extracted before being used in `PROC IML`. Since these are used in more than one of the alternative H2 methods, we decided to create separate `%MACRO`s whose only purpose is the preprocessing/formatting of the `G=` and `MMEqSol=` datasets. They are called `%getC22g`, and `%getGFD`. Finally, there is a third `%MACRO` named `%getGamma`, which calculates the Gamma matrix [see Eq. 13 in Piepho & Möhring (2007)] required for H2 Sim. 10 | These additional `%MACRO`s are all contained in the SAS-file "MACROS getC22g getGFD getGamma.sas". You will find that within the `%MACRO`s `%H2_cullis`, `%H2_oakey` and `%H2RSim`, the respective additional `%MACRO`s are run from github and executed without further need for action by the user. Thus, the addtional macros are included inside some heritability macros. 11 | 12 | 13 | -------------------------------------------------------------------------------- /Alternative Heritability Measures/ASReml-R/.Rhistory: -------------------------------------------------------------------------------- 1 | ########################## 2 | # Handle model estimates # 3 | ########################## 4 | # Genotype Information 5 | list.g <- levels(dat$gen) # list of genotype names 6 | rm(list = ls()) 7 | ####################### 8 | # Import example data # 9 | ####################### 10 | library(agridat) 11 | dat <- john.alpha 12 | ############# 13 | # Fit model # 14 | ############# 15 | library(asreml) 16 | # Genotype as random effect 17 | g.ran <- asreml(fixed = yield ~ rep, 18 | random= ~ gen + rep:block, 19 | data=dat) 20 | ########################## 21 | # Handle model estimates # 22 | ########################## 23 | # Genotype Information 24 | list.g <- levels(dat$gen) # list of genotype names 25 | n.g <- length(list.g) # number of genotypes 26 | G.g.wide <- diag(1, n.g) * vc.g; dimnames(G.g.wide) <- list(list.g, list.g) # G.g matrix 27 | # Genetic variance component 28 | vc.g <- summary(g.ran)$varcomp['gen!gen.var','component'] # VC genotype main effect 29 | G.g.wide <- diag(1, n.g) * vc.g; dimnames(G.g.wide) <- list(list.g, list.g) # G.g matrix 30 | # Genotype as random effect 31 | g.ran <- asreml(fixed = yield ~ rep, 32 | random= ~ gen + rep:block, 33 | data=dat) 34 | rm(list = ls()) 35 | ####################### 36 | # Import example data # 37 | ####################### 38 | library(agridat) 39 | dat <- john.alpha 40 | ############# 41 | # Fit model # 42 | ############# 43 | library(asreml) 44 | # Genotype as random effect 45 | g.ran <- asreml(fixed = yield ~ rep, 46 | random= ~ gen + rep:block, 47 | data=dat) 48 | ########################## 49 | # Handle model estimates # 50 | ########################## 51 | library(data.table) 52 | # Genotype Information 53 | list.g <- levels(dat$gen) # list of genotype names 54 | n.g <- length(list.g) # number of genotypes 55 | # n.rep <- length(levels(dat$rep)) # number of replicates 56 | # Genetic variance component 57 | vc.g <- summary(g.ran)$varcomp['gen!gen.var','component'] # VC genotype main effect 58 | G.g.wide <- diag(1, n.g) * vc.g; dimnames(G.g.wide) <- list(list.g, list.g) # G.g matrix 59 | G.g.long <- data.table(melt(G.g.wide)); names(G.g.long) <- c("gen1", "gen2", "sigma") 60 | -------------------------------------------------------------------------------- /Alternative Heritability Measures/lme4/H2 Oakey.R: -------------------------------------------------------------------------------- 1 | library(agridat) 2 | library(lme4) 3 | library(psych) 4 | library(tidyverse) 5 | 6 | 7 | # get example data -------------------------------------------------------- 8 | dat <- agridat::john.alpha 9 | 10 | 11 | # fit model --------------------------------------------------------------- 12 | # random genotype effect 13 | g_ran <- lmer(data = dat, 14 | formula = yield ~ rep + (1|gen) + (1|rep:block)) 15 | 16 | ### handle model estimates 17 | # to my knowledge, lme4 does not offer a function to 18 | # extract variance-covariance-matrices for BLUPs (a.k.a. prediction error variance [PEV] matrix). 19 | # therefore, I here manually reconstruct mixed model equation for this specific example. 20 | # notice that this solution therefore only works for this specific model! 21 | 22 | vc <- g_ran %>% VarCorr %>% as_tibble # extract estimated variance components (vc) 23 | 24 | # R = varcov-matrix for error term 25 | n <- g_ran %>% summary %>% pluck(residuals) %>% length # numer of observations 26 | vc_e <- vc %>% filter(grp=="Residual") %>% pull(vcov) # error vc 27 | R <- diag(n)*vc_e # R matrix = I_n * vc_e 28 | 29 | # G = varcov-matrx for all random effects 30 | # subset of G regarding genotypic effects 31 | n_g <- g_ran %>% summary %>% pluck("ngrps") %>% pluck("gen") # number of genotypes 32 | vc_g <- vc %>% filter(grp=="gen") %>% pull(vcov) # genotypic vc 33 | G_g <- diag(n_g)*vc_g # gen part of G matrix = I * vc.g 34 | 35 | # subset of G regarding incomplete block effects 36 | n_b <- g_ran %>% summary %>% pluck("ngrps") %>% pluck("rep:block") # number of incomplete blocks 37 | vc_b <- vc %>% filter(grp=="rep:block") %>% pull(vcov) # incomplete block vc 38 | G_b <- diag(n_b)*vc_b # incomplete block part of G matrix = I * vc.b 39 | 40 | G <- bdiag(G_g, G_b) # G is blockdiagonal with G_g and G_b in this example 41 | 42 | # Design Matrices 43 | X <- g_ran %>% getME("X") %>% as.matrix # Design matrix fixed effects 44 | Z <- g_ran %>% getME("Z") %>% as.matrix # Design matrix random effects 45 | 46 | # Mixed Model Equation (HENDERSON 1986; SEARLE et al. 2006) 47 | C11 <- t(X) %*% solve(R) %*% X 48 | C12 <- t(X) %*% solve(R) %*% Z 49 | C21 <- t(Z) %*% solve(R) %*% X 50 | C22 <- t(Z) %*% solve(R) %*% Z + solve(G) 51 | 52 | C <- rbind(cbind(C11, C12), 53 | cbind(C21, C22)) %>% as.matrix # Combine components into one matrix C 54 | 55 | # Mixed Model Equation Solutions 56 | C_inv <- C %>% solve # Inverse of C 57 | C22_g <- C_inv[levels(dat$gen), levels(dat$gen)] # subset of C.inv that refers to genotypic BLUPs 58 | 59 | ED <- diag(n_g) - (solve(G_g) %*% C22_g) # [see p. 813 bottom left in Oakey (2006)] 60 | eM <- ED %>% eigen # obtain eigenvalues 61 | 62 | 63 | # H2 Oakey ---------------------------------------------------------------- 64 | # main method [see eq. (7) in Oakey (2006)] 65 | H2Oakey <- sum(eM$values)/(n_g-1) 66 | H2Oakey # 0.8091336 67 | 68 | # approximate method [see p. 813 top right in Oakey (2006)] 69 | H2Oakey.approx <- 1 - psych::tr( as.matrix(solve(G_g) %*% C22_g / n_g ) ) 70 | H2Oakey.approx # 0.7754197 71 | -------------------------------------------------------------------------------- /Alternative Heritability Measures/lme4/H2 Cullis.R: -------------------------------------------------------------------------------- 1 | library(agridat) 2 | library(lme4) 3 | library(psych) 4 | library(tidyverse) 5 | 6 | 7 | # get example data -------------------------------------------------------- 8 | dat <- agridat::john.alpha 9 | 10 | 11 | # fit model --------------------------------------------------------------- 12 | # random genotype effect 13 | g.ran <- lme4::lmer(data = dat, 14 | formula = yield ~ rep + (1|gen) + (1|rep:block)) 15 | 16 | 17 | # handle model estimates -------------------------------------------------- 18 | # to my knowledge, lme4 does not offer a function to 19 | # extract variance-covariance-matrices for BLUPs (a.k.a. prediction error variance [PEV] matrix). 20 | # therefore, I here manually reconstruct mixed model equation for this specific example. 21 | # notice that this solution therefore only works for this specific model! 22 | 23 | vc <- g.ran %>% VarCorr %>% as_tibble # extract estimated variance components (vc) 24 | 25 | # R = varcov-matrix for error term 26 | n <- g.ran %>% summary %>% pluck(residuals) %>% length # numer of observations 27 | vc_e <- vc %>% filter(grp=="Residual") %>% pull(vcov) # error vc 28 | R <- diag(n)*vc_e # R matrix = I_n * vc_e 29 | 30 | # G = varcov-matrx for all random effects 31 | # subset of G regarding genotypic effects 32 | n_g <- g.ran %>% summary %>% pluck("ngrps") %>% pluck("gen") # number of genotypes 33 | vc_g <- vc %>% filter(grp=="gen") %>% pull(vcov) # genotypic vc 34 | G_g <- diag(n_g)*vc_g # gen part of G matrix = I * vc.g 35 | 36 | # subset of G regarding incomplete block effects 37 | n_b <- g.ran %>% summary %>% pluck("ngrps") %>% pluck("rep:block") # number of incomplete blocks 38 | vc_b <- vc %>% filter(grp=="rep:block") %>% pull(vcov) # incomplete block vc 39 | G_b <- diag(n_b)*vc_b # incomplete block part of G matrix = I * vc.b 40 | 41 | G <- bdiag(G_g, G_b) # G is blockdiagonal with G.g and G.b in this example 42 | 43 | # Design Matrices 44 | X <- g.ran %>% getME("X") %>% as.matrix # Design matrix fixed effects 45 | Z <- g.ran %>% getME("Z") %>% as.matrix # Design matrix random effects 46 | 47 | # Mixed Model Equation (HENDERSON 1986; SEARLE et al. 2006) 48 | C11 <- t(X) %*% solve(R) %*% X 49 | C12 <- t(X) %*% solve(R) %*% Z 50 | C21 <- t(Z) %*% solve(R) %*% X 51 | C22 <- t(Z) %*% solve(R) %*% Z + solve(G) 52 | 53 | C <- rbind(cbind(C11, C12), 54 | cbind(C21, C22)) %>% as.matrix # Combine components into one matrix C 55 | 56 | # Mixed Model Equation Solutions 57 | C_inv <- C %>% solve # Inverse of C 58 | C22_g <- C_inv[levels(dat$gen), levels(dat$gen)] # subset of C.inv that refers to genotypic BLUPs 59 | 60 | # Mean variance of BLUP-difference from C22 matrix of genotypic BLUPs 61 | one <- matrix(1, nrow=n_g, ncol=1) # vector of 1s 62 | P_mu <- diag(n_g, n_g) - one %*% t(one) # P_mu = matrix that centers for overall-mean 63 | vdBLUP_sum <- psych::tr(P_mu %*% C22_g) # sum of all variance of differences = trace of P_mu*C22_g 64 | vdBLUP_avg <- vdBLUP_sum * (2/(n_g*(n_g-1))) # mean variance of BLUP-difference = divide sum by number of genotype pairs 65 | 66 | 67 | # H2 Cullis --------------------------------------------------------------- 68 | H2Cullis <- 1 - (vdBLUP_avg / 2 / vc_g) 69 | H2Cullis #0.8091336 70 | -------------------------------------------------------------------------------- /Alternative Heritability Measures/ASReml-R/H2 Delta (BLUP).R: -------------------------------------------------------------------------------- 1 | rm(list = ls()) 2 | ####################### 3 | # Import example data # 4 | ####################### 5 | library(agridat) 6 | dat <- john.alpha 7 | 8 | ############# 9 | # Fit model # 10 | ############# 11 | library(asreml) 12 | # Genotype as random effect 13 | g.ran <- asreml(fixed = yield ~ rep, 14 | random= ~ gen + rep:block, 15 | data=dat) 16 | 17 | # BLUPs for genotype main effect 18 | g.pred <- predict(g.ran, classify="gen", only="gen", sed=T, vcov=T)$pred 19 | BLUPs.g <- data.table(g.pred$pvals[,c(1,2)]); names(BLUPs.g) <- c("gen","BLUP") 20 | 21 | ########################## 22 | # Handle model estimates # 23 | ########################## 24 | library(data.table) 25 | # Genotype information 26 | list.g <- levels(dat$gen) # list of genotype names 27 | n.g <- length(list.g) # number of genotypes 28 | 29 | # G.g (i.e. estimated G matrix of genotype main effect) 30 | vc.g <- summary(g.ran)$varcomp['gen!gen.var','component'] # VC genotype main effect 31 | G.g.wide <- diag(1, n.g) * vc.g; dimnames(G.g.wide) <- list(list.g, list.g) # G.g matrix 32 | G.g.long <- data.table(reshape::melt(G.g.wide)); names(G.g.long) <- c("gen1","gen2","sigma") # G.g matrix in long format 33 | 34 | # Variance of a difference between genotypic BLUPs (based on C22.g/PEV matrix) 35 | vd.g.wide <- g.pred$sed^2; dimnames(vd.g.wide) <- list(list.g, list.g) # C22.g matrix 36 | vd.g.long <- data.table(reshape::melt(vd.g.wide)); names(vd.g.long) <- c("gen1","gen2","vd") # C22.g matrix in long format 37 | 38 | # merge BLUPs, G.g and C22.g information into "H2D.blup" table 39 | g.var <- G.g.long[gen1==gen2, .(gen1, sigma)]; names(g.var) <- c("gen","var") # variances G.g 40 | g.cov <- G.g.long[gen1!=gen2] ; names(g.cov) <- c("gen1","gen2","cov") # covariances of G.g 41 | H2D.blup <- merge(vd.g.long, g.cov, all=T) 42 | for (i in 1:2){ 43 | temp <- merge(BLUPs.g, g.var, by="gen"); names(temp) <- c(paste0(names(temp),i)) # merge BLUPs and variances for each genotye 44 | H2D.blup <- merge(H2D.blup, temp, by=paste0("gen",i)) # merge this for both gen1 and gen2, respectively, to result table 45 | } 46 | 47 | # formatting 48 | setcolorder(H2D.blup, c("gen1","BLUP1","gen2","BLUP2","var1","var2","cov","vd")) 49 | H2D.blup <- H2D.blup[order(gen1, gen2)] 50 | H2D.blup[, i.is.j := gen1==gen2] # i=j is not a pair 51 | H2D.blup[, i.larger.j := as.numeric(gen1) > as.numeric(gen2)] # i>j is a duplicate pair 52 | 53 | ### Compute H2 Delta based on BLUPs 54 | # H2 Delta ij 55 | H2D.blup[i.is.j==FALSE, Numerator := var1 + var2 - 2*cov - vd] 56 | H2D.blup[i.is.j==FALSE, Denominator := var1 + var2 - 2*cov ] 57 | H2D.blup[i.is.j==FALSE, H2D.ij := Numerator / Denominator] 58 | # H2 Delta i. 59 | H2D.blup[i.is.j==FALSE, H2D.i := mean(H2D.ij), by="gen1"] 60 | # H2 Delta .. 61 | H2D.blup[i.is.j==FALSE & i.larger.j==FALSE, H2D := mean(H2D.ij)] 62 | 63 | ####################### 64 | ### H2 Delta (BLUP) ### 65 | ####################### 66 | 67 | # H2 Delta .. (overall H2) 68 | H2D.. <- as.numeric(unique(na.omit(H2D.blup[,.(H2D)]))) 69 | H2D.. 70 | # H2 Delta i. (mean H2 per genotype) 71 | H2Di. <- unique(na.omit(H2D.blup[,.(gen1, H2D.i)])) 72 | H2Di. 73 | # H2 Delta ij (H2 per genotype pair) 74 | H2Dij <- unique(na.omit(H2D.blup[i.larger.j==FALSE,.(gen1, gen2, H2D.ij)])) 75 | mergeit <- H2D.blup[,c("gen1","gen2","var1","var2","cov","vd")] 76 | H2Dij <- merge(H2Dij, mergeit, by=c("gen1", "gen2"), all = FALSE) 77 | H2Dij -------------------------------------------------------------------------------- /Alternative Heritability Measures/lme4/H2 Simulated.R: -------------------------------------------------------------------------------- 1 | library(agridat) 2 | library(lme4) 3 | library(tidyverse) 4 | 5 | # get example data -------------------------------------------------------- 6 | dat <- agridat::john.alpha 7 | 8 | 9 | # fit model --------------------------------------------------------------- 10 | # random genotype effect 11 | g_ran <- lmer(data = dat, 12 | formula = yield ~ rep + (1|gen) + (1|rep:block)) 13 | 14 | ### handle model estimates 15 | # to my knowledge, lme4 does not offer a function to 16 | # extract variance-covariance-matrices for BLUPs (a.k.a. prediction error variance [PEV] matrix). 17 | # therefore, I here manually reconstruct mixed model equation for this specific example. 18 | # notice that this solution therefore only works for this specific model! 19 | 20 | vc <- g_ran %>% VarCorr %>% as_tibble # extract estimated variance components (vc) 21 | 22 | # R = varcov-matrix for error term 23 | n <- g_ran %>% summary %>% pluck(residuals) %>% length # numer of observations 24 | vc_e <- vc %>% filter(grp=="Residual") %>% pull(vcov) # error vc 25 | R <- diag(n)*vc_e # R matrix = I_n * vc_e 26 | 27 | # G = varcov-matrx for all random effects 28 | # subset of G regarding genotypic effects 29 | n_g <- g_ran %>% summary %>% pluck("ngrps") %>% pluck("gen") # number of genotypes 30 | vc_g <- vc %>% filter(grp=="gen") %>% pull(vcov) # genotypic vc 31 | G_g <- diag(n_g)*vc_g # gen part of G matrix = I * vc.g 32 | 33 | # subset of G regarding incomplete block effects 34 | n_b <- g_ran %>% summary %>% pluck("ngrps") %>% pluck("rep:block") # number of incomplete blocks 35 | vc_b <- vc %>% filter(grp=="rep:block") %>% pull(vcov) # incomplete block vc 36 | G_b <- diag(n_b)*vc_b # incomplete block part of G matrix = I * vc.b 37 | 38 | G <- bdiag(G_g, G_b) # G is blockdiagonal with G_g and G_b in this example 39 | F <- G[diag(G)==vc_g, ] 40 | D <- G[diag(G)==vc_g, diag(G)==vc_g]; all(D == G_g) 41 | 42 | # Design Matrices 43 | X <- g_ran %>% getME("X") %>% as.matrix # Design matrix fixed effects 44 | Z <- g_ran %>% getME("Z") %>% as.matrix # Design matrix random effects 45 | 46 | # Mixed Model Equation (HENDERSON 1986; SEARLE et al. 2006) 47 | C11 <- t(X) %*% solve(R) %*% X 48 | C12 <- t(X) %*% solve(R) %*% Z 49 | C21 <- t(Z) %*% solve(R) %*% X 50 | C22 <- t(Z) %*% solve(R) %*% Z + solve(G) 51 | 52 | C <- rbind(cbind(C11, C12), 53 | cbind(C21, C22)) %>% as.matrix # Combine components into one matrix C 54 | 55 | # Mixed Model Equation Solutions 56 | C_inv <- C %>% solve # Inverse of C 57 | C22_g <- C_inv[levels(dat$gen), levels(dat$gen)] # subset of C.inv that refers to genotypic BLUPs 58 | C22 <- C_inv[-c(1:3), -c(1:3)] # subset of C.inv that refers to all BLUPS (columns 1-3 refer to fixed effects) 59 | 60 | # Gamma 61 | M <- G - C22 62 | G_inv <- G %>% solve 63 | Q <- F %*% G_inv %*% M %*% G_inv %*% t(F) 64 | Omega <- rbind(cbind(D,Q), cbind(Q,Q)) 65 | svdout <- Omega %>% svd 66 | Gamma <- svdout$u %*% diag(sqrt(svdout$d)) 67 | 68 | ### Simulation 69 | n_sim <- 10000 # number of simulation runs 70 | h2 <- list() 71 | R <- list() 72 | 73 | for (i in 1:n_sim){ 74 | z <- rnorm(n=(2*n_g), mean=0, sd=1) 75 | w <- Gamma %*% z 76 | g_hat <- w[1 : n_g ] 77 | g_true <- w[(n_g+1):(2*n_g)] 78 | g_hat_s <- g_hat %>% sort(decreasing=T) 79 | selmean <- list() 80 | for (j in 1:n_g){ 81 | selmean[[j]] <- g_hat_s[1:j] %>% mean 82 | } 83 | R[[i]] <- selmean %>% unlist 84 | h2[[i]] <- (t(g_hat) %*% g_true)**2 / (t(g_true) %*% g_true %*% t(g_hat) %*% g_hat) 85 | } 86 | 87 | ### H2 Simulated 88 | H2Sim <- h2 %>% unlist %>% mean 89 | H2Sim # 0.7719582 -------------------------------------------------------------------------------- /Alternative Heritability Measures/ASReml-R/H2 Delta (BLUE).R: -------------------------------------------------------------------------------- 1 | rm(list = ls()) 2 | ####################### 3 | # Import example data # 4 | ####################### 5 | library(agridat) 6 | dat <- john.alpha 7 | 8 | ############# 9 | # Fit model # 10 | ############# 11 | library(asreml) 12 | # Genotype as random effect 13 | g.ran <- asreml(fixed = yield ~ rep, 14 | random= ~ gen + rep:block, 15 | data=dat) 16 | 17 | # BLUPs for genotype main effect 18 | g.pred <- predict(g.ran, classify="gen", only="gen", sed=T, vcov=T)$pred 19 | BLUPs.g <- data.table(g.pred$pvals[,c(1,2)]); names(BLUPs.g) <- c("gen","BLUP") 20 | 21 | # Genotype as fixed effect 22 | g.fix <- asreml(fixed = yield ~ gen + rep, 23 | random = ~ rep:block, 24 | data=dat) 25 | 26 | # Least Squares Mean for genotype main effect 27 | g.lsm <- predict(g.fix, classify="gen", sed=T)$pred 28 | LSM.g <- data.table(g.lsm$pvals[,c(1,2)]); names(LSM.g) <- c("gen", "LSmean") 29 | 30 | ########################## 31 | # Handle model estimates # 32 | ########################## 33 | library(data.table) 34 | # Genotype information 35 | list.g <- levels(dat$gen) # list of genotype names 36 | n.g <- length(list.g) # number of genotypes 37 | 38 | # G.g (i.e. estimated G matrix of genotype main effect) 39 | vc.g <- summary(g.ran)$varcomp['gen!gen.var','component'] # VC genotype main effect 40 | G.g.wide <- diag(1, n.g) * vc.g; dimnames(G.g.wide) <- list(list.g, list.g) # G.g matrix 41 | G.g.long <- data.table(reshape::melt(G.g.wide)); names(G.g.long) <- c("gen1","gen2","sigma") # G.g matrix in long format 42 | 43 | # Variance of a difference between genotype lsmeans (based on C11 matrix) 44 | vd.lsm.wide <- g.lsm$sed^2; dimnames(vd.lsm.wide) <- list(list.g, list.g) 45 | vd.lsm.long <- data.table(reshape::melt(vd.lsm.wide)); names(vd.lsm.long) <- c("gen1","gen2","vd") 46 | 47 | # merge BLUPs, G.g and C22.g information into "H2D.blue" table 48 | g.var <- G.g.long[gen1==gen2, .(gen1, sigma)]; names(g.var) <- c("gen","var") # variances G.g 49 | g.cov <- G.g.long[gen1!=gen2] ; names(g.cov) <- c("gen1","gen2","cov") # covariances of G.g 50 | H2D.blue <- merge(vd.lsm.long, g.cov, all=T) 51 | for (i in 1:2){ 52 | temp <- merge(LSM.g, g.var, by="gen"); names(temp) <- c(paste0(names(temp),i)) # merge BLUPs and variances for each genotye 53 | H2D.blue <- merge(H2D.blue, temp, by=paste0("gen",i)) # merge this for both gen1 and gen2, respectively, to result table 54 | } 55 | 56 | # formatting 57 | setcolorder(H2D.blue, c("gen1","LSmean1","gen2","LSmean2","var1","var2","cov","vd")) 58 | H2D.blue <- H2D.blue[order(gen1, gen2)] 59 | H2D.blue[, i.is.j := gen1==gen2] # i=j is not a pair 60 | H2D.blue[, i.larger.j := as.numeric(gen1) > as.numeric(gen2)] # i>j is a duplicate pair 61 | 62 | ### Compute H2 Delta based on BLUEs 63 | h.mean <- psych::harmonic.mean 64 | # H2 Delta ij 65 | H2D.blue[i.is.j==FALSE, Numerator := var1 + var2 - 2*cov ] 66 | H2D.blue[i.is.j==FALSE, Denominator := var1 + var2 - 2*cov + vd] 67 | H2D.blue[i.is.j==FALSE, H2D.ij := Numerator / Denominator] 68 | # H2 Delta i. 69 | H2D.blue[i.is.j==FALSE, H2D.i := h.mean(H2D.ij), by="gen1"] 70 | # H2 Delta .. 71 | H2D.blue[i.is.j==FALSE & i.larger.j==FALSE, H2D := h.mean(H2D.ij)] 72 | 73 | ####################### 74 | ### H2 Delta (BLUE) ### 75 | ####################### 76 | 77 | # H2 Delta .. (overall H2) 78 | H2D.. <- as.numeric(unique(na.omit(H2D.blue[,.(H2D)]))) 79 | H2D.. 80 | # H2 Delta i. (mean H2 per genotype) 81 | H2Di. <- unique(na.omit(H2D.blue[,.(gen1, H2D.i)])) 82 | H2Di. 83 | # H2 Delta ij (H2 per genotype pair) 84 | H2Dij <- unique(na.omit(H2D.blue[i.larger.j==FALSE,.(gen1, gen2, H2D.ij)])) 85 | mergeit <- H2D.blue[,c("gen1","gen2","var1","var2","cov","vd")] 86 | H2Dij <- merge(H2Dij, mergeit, by=c("gen1", "gen2"), all = FALSE) 87 | H2Dij -------------------------------------------------------------------------------- /Alternative Heritability Measures/SAS/example H2_Oakey.sas: -------------------------------------------------------------------------------- 1 | /* Data taken from: */ 2 | /* John, J. A., and E. R. Williams, 1995 Cyclic and Computer */ 3 | /* Generated Designs. Chapman & Hall, London, p.146 */ 4 | /* yield trial with oats laid out as an a-design. */ 5 | /* */ 6 | /* The trial had 24 genotypes, three complete replications, */ 7 | /* and six incomplete blocks within each replication. The */ 8 | /* block size was four. The data were analyzed by a linear */ 9 | /* mixed model with effects for genotypes, replicates, and */ 10 | /* incomplete blocks. Blocks were modeled as independent */ 11 | /* random effects to recover interblock information */ 12 | 13 | data a; 14 | input 15 | rep block gen y; 16 | datalines; 17 | 1 1 11 4.1172 18 | 1 1 4 4.4461 19 | 1 1 5 5.8757 20 | 1 1 22 4.5784 21 | 1 2 21 4.6540 22 | 1 2 10 4.1736 23 | 1 2 20 4.0141 24 | 1 2 2 4.3350 25 | 1 3 23 4.2323 26 | 1 3 14 4.7572 27 | 1 3 16 4.4906 28 | 1 3 18 3.9737 29 | 1 4 13 4.2530 30 | 1 4 3 3.3420 31 | 1 4 19 4.7269 32 | 1 4 8 4.9989 33 | 1 5 17 4.7876 34 | 1 5 15 5.0902 35 | 1 5 7 4.1505 36 | 1 5 1 5.1202 37 | 1 6 6 4.7085 38 | 1 6 12 5.2560 39 | 1 6 24 4.9577 40 | 1 6 9 3.3986 41 | 2 1 8 3.9926 42 | 2 1 20 3.6056 43 | 2 1 14 4.5294 44 | 2 1 4 4.3599 45 | 2 2 24 3.9039 46 | 2 2 15 4.9114 47 | 2 2 3 3.7999 48 | 2 2 23 4.3042 49 | 2 3 12 5.3127 50 | 2 3 11 5.1163 51 | 2 3 21 5.3802 52 | 2 3 17 5.0744 53 | 2 4 5 5.1202 54 | 2 4 9 4.2955 55 | 2 4 10 4.9057 56 | 2 4 1 5.7161 57 | 2 5 2 5.1566 58 | 2 5 18 5.0988 59 | 2 5 13 5.4840 60 | 2 5 22 5.0969 61 | 2 6 19 5.3148 62 | 2 6 7 4.6297 63 | 2 6 6 5.1751 64 | 2 6 16 5.3024 65 | 3 1 11 3.9205 66 | 3 1 1 4.6512 67 | 3 1 14 4.3887 68 | 3 1 19 4.5552 69 | 3 2 2 4.0510 70 | 3 2 15 4.6783 71 | 3 2 9 3.1407 72 | 3 2 8 3.9821 73 | 3 3 17 4.3234 74 | 3 3 18 4.2486 75 | 3 3 4 4.3960 76 | 3 3 6 4.2474 77 | 3 4 12 4.1746 78 | 3 4 13 4.7512 79 | 3 4 10 4.0875 80 | 3 4 23 3.8721 81 | 3 5 21 4.4130 82 | 3 5 22 4.2397 83 | 3 5 16 4.3852 84 | 3 5 24 3.5655 85 | 3 6 3 2.8873 86 | 3 6 5 4.1972 87 | 3 6 20 3.7349 88 | 3 6 7 3.6096 89 | ;RUN; 90 | 91 | /**************************************/ 92 | /* include macro directly from github */ 93 | /**************************************/ 94 | /* Macro %H2_Oakey */ 95 | filename _inbox "%sysfunc(getoption(work))/MACROS getC22g getGFD getGamma.sas"; 96 | proc http method="get" 97 | url="https://raw.githubusercontent.com/PaulSchmidtGit/Heritability/master/Alternative%20Heritability%20Measures/SAS/MACRO%20H2_Oakey.sas" out=_inbox; 98 | run; %Include _inbox; filename _inbox clear; 99 | 100 | ods html close; *Turn html results viewer off; 101 | 102 | /*************/ 103 | /* fit model */ 104 | /*************/ 105 | 106 | /* Genotype as random effect */ 107 | proc mixed data=a mmeqsol; 108 | class rep block gen; 109 | model y= rep /S; 110 | random gen rep*block /G; 111 | ods output MMEQSOL=MmeqSol G=G SOLUTIONF=SolutionF; 112 | run; 113 | 114 | /*****************/ 115 | /* H2 estimation */ 116 | /*****************/ 117 | %H2Oakey(ENTRY_NAME=gen, MMEQSOL=MmeqSol, G=G, SOLUTIONF=SolutionF, OUTPUT=H2oakey); 118 | 119 | ods html; *Turn html results viewer on; 120 | 121 | /* Show results */ 122 | title "H2 'Oakey'"; 123 | proc print data=H2oakey label; 124 | run; 125 | -------------------------------------------------------------------------------- /Alternative Heritability Measures/SAS/example H2_Cullis.sas: -------------------------------------------------------------------------------- 1 | /* Data taken from: */ 2 | /* John, J. A., and E. R. Williams, 1995 Cyclic and Computer */ 3 | /* Generated Designs. Chapman & Hall, London, p.146 */ 4 | /* yield trial with oats laid out as an a-design. */ 5 | /* */ 6 | /* The trial had 24 genotypes, three complete replications, */ 7 | /* and six incomplete blocks within each replication. The */ 8 | /* block size was four. The data were analyzed by a linear */ 9 | /* mixed model with effects for genotypes, replicates, and */ 10 | /* incomplete blocks. Blocks were modeled as independent */ 11 | /* random effects to recover interblock information */ 12 | 13 | DATA a; 14 | INPUT 15 | rep block gen y; 16 | DATALINES; 17 | 1 1 11 4.1172 18 | 1 1 4 4.4461 19 | 1 1 5 5.8757 20 | 1 1 22 4.5784 21 | 1 2 21 4.6540 22 | 1 2 10 4.1736 23 | 1 2 20 4.0141 24 | 1 2 2 4.3350 25 | 1 3 23 4.2323 26 | 1 3 14 4.7572 27 | 1 3 16 4.4906 28 | 1 3 18 3.9737 29 | 1 4 13 4.2530 30 | 1 4 3 3.3420 31 | 1 4 19 4.7269 32 | 1 4 8 4.9989 33 | 1 5 17 4.7876 34 | 1 5 15 5.0902 35 | 1 5 7 4.1505 36 | 1 5 1 5.1202 37 | 1 6 6 4.7085 38 | 1 6 12 5.2560 39 | 1 6 24 4.9577 40 | 1 6 9 3.3986 41 | 2 1 8 3.9926 42 | 2 1 20 3.6056 43 | 2 1 14 4.5294 44 | 2 1 4 4.3599 45 | 2 2 24 3.9039 46 | 2 2 15 4.9114 47 | 2 2 3 3.7999 48 | 2 2 23 4.3042 49 | 2 3 12 5.3127 50 | 2 3 11 5.1163 51 | 2 3 21 5.3802 52 | 2 3 17 5.0744 53 | 2 4 5 5.1202 54 | 2 4 9 4.2955 55 | 2 4 10 4.9057 56 | 2 4 1 5.7161 57 | 2 5 2 5.1566 58 | 2 5 18 5.0988 59 | 2 5 13 5.4840 60 | 2 5 22 5.0969 61 | 2 6 19 5.3148 62 | 2 6 7 4.6297 63 | 2 6 6 5.1751 64 | 2 6 16 5.3024 65 | 3 1 11 3.9205 66 | 3 1 1 4.6512 67 | 3 1 14 4.3887 68 | 3 1 19 4.5552 69 | 3 2 2 4.0510 70 | 3 2 15 4.6783 71 | 3 2 9 3.1407 72 | 3 2 8 3.9821 73 | 3 3 17 4.3234 74 | 3 3 18 4.2486 75 | 3 3 4 4.3960 76 | 3 3 6 4.2474 77 | 3 4 12 4.1746 78 | 3 4 13 4.7512 79 | 3 4 10 4.0875 80 | 3 4 23 3.8721 81 | 3 5 21 4.4130 82 | 3 5 22 4.2397 83 | 3 5 16 4.3852 84 | 3 5 24 3.5655 85 | 3 6 3 2.8873 86 | 3 6 5 4.1972 87 | 3 6 20 3.7349 88 | 3 6 7 3.6096 89 | ;RUN; 90 | 91 | /**************************************/ 92 | /* include macro directly from github */ 93 | /**************************************/ 94 | 95 | /* Macro %H2_Cullis */ 96 | filename _inbox "%sysfunc(getoption(work))/MACRO H2_Cullis.sas"; 97 | proc http method="get" 98 | url="https://raw.githubusercontent.com/PaulSchmidtGit/Heritability/master/Alternative%20Heritability%20Measures/SAS/MACRO%20H2_Cullis.sas" out=_inbox; 99 | run; %Include _inbox; filename _inbox clear; 100 | 101 | ODS HTML CLOSE; *Turn html results viewer off; 102 | 103 | /*************/ 104 | /* fit model */ 105 | /*************/ 106 | 107 | /* Genotype as random effect */ 108 | PROC MIXED DATA=a MMEQSOL; 109 | CLASS rep block gen; 110 | MODEL y = rep /S; 111 | RANDOM gen rep*block /G; 112 | ODS OUTPUT COVPARMS=Covparms MMEQSOL=MmeqSol SOLUTIONF=SolutionF; 113 | RUN; 114 | 115 | /*****************/ 116 | /* H2 estimation */ 117 | /*****************/ 118 | %H2_cullis(ENTRY_NAME=gen, COVPARMS=Covparms, MMEQSOL=Mmeqsol, SOLUTIONF=SolutionF, OUTPUT=H2Cullis); 119 | 120 | ods html; *Turn html results viewer on; 121 | 122 | /* Show results */ 123 | TITLE "H2 'Cullis'"; 124 | PROC PRINT DATA=H2Cullis LABEL; 125 | RUN; 126 | 127 | 128 | 129 | -------------------------------------------------------------------------------- /Alternative Heritability Measures/SAS/example H2_sim.sas: -------------------------------------------------------------------------------- 1 | /* Data taken from: */ 2 | /* John, J. A., and E. R. Williams, 1995 Cyclic and Computer */ 3 | /* Generated Designs. Chapman & Hall, London, p.146 */ 4 | /* yield trial with oats laid out as an a-design. */ 5 | /* */ 6 | /* The trial had 24 genotypes, three complete replications, */ 7 | /* and six incomplete blocks within each replication. The */ 8 | /* block size was four. The data were analyzed by a linear */ 9 | /* mixed model with effects for genotypes, replicates, and */ 10 | /* incomplete blocks. Blocks were modeled as independent */ 11 | /* random effects to recover interblock information */ 12 | 13 | data a; 14 | input 15 | rep block gen y; 16 | datalines; 17 | 1 1 11 4.1172 18 | 1 1 4 4.4461 19 | 1 1 5 5.8757 20 | 1 1 22 4.5784 21 | 1 2 21 4.6540 22 | 1 2 10 4.1736 23 | 1 2 20 4.0141 24 | 1 2 2 4.3350 25 | 1 3 23 4.2323 26 | 1 3 14 4.7572 27 | 1 3 16 4.4906 28 | 1 3 18 3.9737 29 | 1 4 13 4.2530 30 | 1 4 3 3.3420 31 | 1 4 19 4.7269 32 | 1 4 8 4.9989 33 | 1 5 17 4.7876 34 | 1 5 15 5.0902 35 | 1 5 7 4.1505 36 | 1 5 1 5.1202 37 | 1 6 6 4.7085 38 | 1 6 12 5.2560 39 | 1 6 24 4.9577 40 | 1 6 9 3.3986 41 | 2 1 8 3.9926 42 | 2 1 20 3.6056 43 | 2 1 14 4.5294 44 | 2 1 4 4.3599 45 | 2 2 24 3.9039 46 | 2 2 15 4.9114 47 | 2 2 3 3.7999 48 | 2 2 23 4.3042 49 | 2 3 12 5.3127 50 | 2 3 11 5.1163 51 | 2 3 21 5.3802 52 | 2 3 17 5.0744 53 | 2 4 5 5.1202 54 | 2 4 9 4.2955 55 | 2 4 10 4.9057 56 | 2 4 1 5.7161 57 | 2 5 2 5.1566 58 | 2 5 18 5.0988 59 | 2 5 13 5.4840 60 | 2 5 22 5.0969 61 | 2 6 19 5.3148 62 | 2 6 7 4.6297 63 | 2 6 6 5.1751 64 | 2 6 16 5.3024 65 | 3 1 11 3.9205 66 | 3 1 1 4.6512 67 | 3 1 14 4.3887 68 | 3 1 19 4.5552 69 | 3 2 2 4.0510 70 | 3 2 15 4.6783 71 | 3 2 9 3.1407 72 | 3 2 8 3.9821 73 | 3 3 17 4.3234 74 | 3 3 18 4.2486 75 | 3 3 4 4.3960 76 | 3 3 6 4.2474 77 | 3 4 12 4.1746 78 | 3 4 13 4.7512 79 | 3 4 10 4.0875 80 | 3 4 23 3.8721 81 | 3 5 21 4.4130 82 | 3 5 22 4.2397 83 | 3 5 16 4.3852 84 | 3 5 24 3.5655 85 | 3 6 3 2.8873 86 | 3 6 5 4.1972 87 | 3 6 20 3.7349 88 | 3 6 7 3.6096 89 | ;RUN; 90 | 91 | /**************************************/ 92 | /* include macro directly from github */ 93 | /**************************************/ 94 | /* Macro %H2RSim */ 95 | filename _inbox "%sysfunc(getoption(work))/Macro H2_R_Simulated.sas"; 96 | proc http method="get" 97 | url="https://raw.githubusercontent.com/PaulSchmidtGit/Heritability/master/Alternative%20Heritability%20Measures/SAS/MACRO%20H2_R_Simulated.sas" out=_inbox; 98 | run; %Include _inbox; filename _inbox clear; 99 | 100 | ODS HTML CLOSE; *Turn html results viewer off; 101 | /*************/ 102 | /* fit model */ 103 | /*************/ 104 | 105 | /* Genotype as random effect */ 106 | proc mixed data=a mmeqsol; 107 | class rep block gen; 108 | model y= rep /S; 109 | random gen rep*block /G; 110 | ods output MMEqSol=MmeqSol G=G SOLUTIONF=SolutionF; 111 | run; 112 | 113 | /*********************/ 114 | /* H2 & R estimation */ 115 | /*********************/ 116 | %H2RSim(ENTRY_NAME=gen, MMEQSOL=MmeqSol, G=G, SOLUTIONF=SolutionF, n_sim=10000, H_OUT=H2_sim, R_OUT=R_sim); 117 | 118 | ods html; *Turn html results viewer on; 119 | 120 | /* Show results */ 121 | TITLE "Ad hoc H2_sim"; 122 | PROC PRINT DATA=H2_sim LABEL; 123 | RUN; 124 | 125 | TITLE "Simulated Response to Selection"; 126 | PROC PRINT DATA=R_sim LABEL; 127 | RUN; 128 | 129 | 130 | 131 | 132 | 133 | -------------------------------------------------------------------------------- /Alternative Heritability Measures/SAS/example H2_BLUP_BLUE.sas: -------------------------------------------------------------------------------- 1 | /* Data taken from: */ 2 | /* John, J. A., and E. R. Williams, 1995 Cyclic and Computer */ 3 | /* Generated Designs. Chapman & Hall, London, p.146 */ 4 | /* yield trial with oats laid out as an a-design. */ 5 | /* */ 6 | /* The trial had 24 genotypes, three complete replications, */ 7 | /* and six incomplete blocks within each replication. The */ 8 | /* block size was four. The data were analyzed by a linear */ 9 | /* mixed model with effects for genotypes, replicates, and */ 10 | /* incomplete blocks. Blocks were modeled as independent */ 11 | /* random effects to recover interblock information */ 12 | 13 | data a; 14 | input 15 | rep block gen y; 16 | datalines; 17 | 1 1 11 4.1172 18 | 1 1 4 4.4461 19 | 1 1 5 5.8757 20 | 1 1 22 4.5784 21 | 1 2 21 4.6540 22 | 1 2 10 4.1736 23 | 1 2 20 4.0141 24 | 1 2 2 4.3350 25 | 1 3 23 4.2323 26 | 1 3 14 4.7572 27 | 1 3 16 4.4906 28 | 1 3 18 3.9737 29 | 1 4 13 4.2530 30 | 1 4 3 3.3420 31 | 1 4 19 4.7269 32 | 1 4 8 4.9989 33 | 1 5 17 4.7876 34 | 1 5 15 5.0902 35 | 1 5 7 4.1505 36 | 1 5 1 5.1202 37 | 1 6 6 4.7085 38 | 1 6 12 5.2560 39 | 1 6 24 4.9577 40 | 1 6 9 3.3986 41 | 2 1 8 3.9926 42 | 2 1 20 3.6056 43 | 2 1 14 4.5294 44 | 2 1 4 4.3599 45 | 2 2 24 3.9039 46 | 2 2 15 4.9114 47 | 2 2 3 3.7999 48 | 2 2 23 4.3042 49 | 2 3 12 5.3127 50 | 2 3 11 5.1163 51 | 2 3 21 5.3802 52 | 2 3 17 5.0744 53 | 2 4 5 5.1202 54 | 2 4 9 4.2955 55 | 2 4 10 4.9057 56 | 2 4 1 5.7161 57 | 2 5 2 5.1566 58 | 2 5 18 5.0988 59 | 2 5 13 5.4840 60 | 2 5 22 5.0969 61 | 2 6 19 5.3148 62 | 2 6 7 4.6297 63 | 2 6 6 5.1751 64 | 2 6 16 5.3024 65 | 3 1 11 3.9205 66 | 3 1 1 4.6512 67 | 3 1 14 4.3887 68 | 3 1 19 4.5552 69 | 3 2 2 4.0510 70 | 3 2 15 4.6783 71 | 3 2 9 3.1407 72 | 3 2 8 3.9821 73 | 3 3 17 4.3234 74 | 3 3 18 4.2486 75 | 3 3 4 4.3960 76 | 3 3 6 4.2474 77 | 3 4 12 4.1746 78 | 3 4 13 4.7512 79 | 3 4 10 4.0875 80 | 3 4 23 3.8721 81 | 3 5 21 4.4130 82 | 3 5 22 4.2397 83 | 3 5 16 4.3852 84 | 3 5 24 3.5655 85 | 3 6 3 2.8873 86 | 3 6 5 4.1972 87 | 3 6 20 3.7349 88 | 3 6 7 3.6096 89 | ;RUN; 90 | 91 | /**************************************/ 92 | /* include macro directly from github */ 93 | /**************************************/ 94 | 95 | /* Macro %H2_BLUP_BLUE */ 96 | filename _inbox "%sysfunc(getoption(work))/Macro H2_Piepho.sas"; 97 | proc http method="get" 98 | url="https://raw.githubusercontent.com/PaulSchmidtGit/Heritability/master/Alternative%20Heritability%20Measures/SAS/MACRO%20H2_BLUP_BLUE.sas" out=_inbox; 99 | run; %Include _inbox; filename _inbox clear; 100 | 101 | 102 | ODS HTML CLOSE; *Turn html results viewer off; 103 | 104 | /**************/ 105 | /* fit models */ 106 | /**************/ 107 | data a; 108 | set a; 109 | Mu=1; * Create a dummy column "Mu" full of 1s. See model statement in proc mixed below; 110 | run; 111 | 112 | /* Genotype as random effect */ 113 | proc mixed data=a; 114 | class Mu rep block gen; 115 | model y= Mu rep /S noint ddfm=kr; * Use noint, but "Mu" as pseudo intercept in order to ... ; 116 | random gen rep*block /S; 117 | lsmeans Mu; * ... obtain an overall mean via the lsmeans statement; 118 | ods output lsmeans=Mu SolutionR=BLUPs; 119 | run; 120 | 121 | /* Genotype as fixed effect */ 122 | proc mixed data=a; 123 | class rep block gen; 124 | model y=gen rep /ddfm=kr; 125 | random rep*block; 126 | lsmeans gen; 127 | ods output lsmeans=BLUEs; 128 | run; 129 | 130 | /*****************/ 131 | /* H2 estimation */ 132 | /*****************/ 133 | %H2_BLUE_BLUP(ENTRY_NAME=gen, LSM_MU=Mu, SOLUTIONR=BLUPs, LSM_G=BLUEs, OUTPUT=H2blupblue); 134 | 135 | ods html; *Turn html results viewer on; 136 | 137 | /* Show results */ 138 | title "H2 'BLUP BLUE'"; 139 | proc print data=H2blupblue label; 140 | run; 141 | -------------------------------------------------------------------------------- /Alternative Heritability Measures/SAS/example H2_Piepho.sas: -------------------------------------------------------------------------------- 1 | /* Data taken from: */ 2 | /* John, J. A., and E. R. Williams, 1995 Cyclic and Computer */ 3 | /* Generated Designs. Chapman & Hall, London, p.146 */ 4 | /* yield trial with oats laid out as an a-design. */ 5 | /* */ 6 | /* The trial had 24 genotypes, three complete replications, */ 7 | /* and six incomplete blocks within each replication. The */ 8 | /* block size was four. The data were analyzed by a linear */ 9 | /* mixed model with effects for genotypes, replicates, and */ 10 | /* incomplete blocks. Blocks were modeled as independent */ 11 | /* random effects to recover interblock information */ 12 | 13 | data a; 14 | input 15 | rep block gen y; 16 | datalines; 17 | 1 1 11 4.1172 18 | 1 1 4 4.4461 19 | 1 1 5 5.8757 20 | 1 1 22 4.5784 21 | 1 2 21 4.6540 22 | 1 2 10 4.1736 23 | 1 2 20 4.0141 24 | 1 2 2 4.3350 25 | 1 3 23 4.2323 26 | 1 3 14 4.7572 27 | 1 3 16 4.4906 28 | 1 3 18 3.9737 29 | 1 4 13 4.2530 30 | 1 4 3 3.3420 31 | 1 4 19 4.7269 32 | 1 4 8 4.9989 33 | 1 5 17 4.7876 34 | 1 5 15 5.0902 35 | 1 5 7 4.1505 36 | 1 5 1 5.1202 37 | 1 6 6 4.7085 38 | 1 6 12 5.2560 39 | 1 6 24 4.9577 40 | 1 6 9 3.3986 41 | 2 1 8 3.9926 42 | 2 1 20 3.6056 43 | 2 1 14 4.5294 44 | 2 1 4 4.3599 45 | 2 2 24 3.9039 46 | 2 2 15 4.9114 47 | 2 2 3 3.7999 48 | 2 2 23 4.3042 49 | 2 3 12 5.3127 50 | 2 3 11 5.1163 51 | 2 3 21 5.3802 52 | 2 3 17 5.0744 53 | 2 4 5 5.1202 54 | 2 4 9 4.2955 55 | 2 4 10 4.9057 56 | 2 4 1 5.7161 57 | 2 5 2 5.1566 58 | 2 5 18 5.0988 59 | 2 5 13 5.4840 60 | 2 5 22 5.0969 61 | 2 6 19 5.3148 62 | 2 6 7 4.6297 63 | 2 6 6 5.1751 64 | 2 6 16 5.3024 65 | 3 1 11 3.9205 66 | 3 1 1 4.6512 67 | 3 1 14 4.3887 68 | 3 1 19 4.5552 69 | 3 2 2 4.0510 70 | 3 2 15 4.6783 71 | 3 2 9 3.1407 72 | 3 2 8 3.9821 73 | 3 3 17 4.3234 74 | 3 3 18 4.2486 75 | 3 3 4 4.3960 76 | 3 3 6 4.2474 77 | 3 4 12 4.1746 78 | 3 4 13 4.7512 79 | 3 4 10 4.0875 80 | 3 4 23 3.8721 81 | 3 5 21 4.4130 82 | 3 5 22 4.2397 83 | 3 5 16 4.3852 84 | 3 5 24 3.5655 85 | 3 6 3 2.8873 86 | 3 6 5 4.1972 87 | 3 6 20 3.7349 88 | 3 6 7 3.6096 89 | ; RUN; 90 | 91 | /**************************************/ 92 | /* include macro directly from github */ 93 | /**************************************/ 94 | 95 | /* Macro %H2_piepho */ 96 | filename _inbox "%sysfunc(getoption(work))/Macro H2_Piepho.sas"; 97 | proc http method="get" 98 | url="https://raw.githubusercontent.com/PaulSchmidtGit/Heritability/master/Alternative%20Heritability%20Measures/SAS/MACRO%20H2_Piepho.sas" out=_inbox; 99 | run; %Include _inbox; filename _inbox clear; 100 | 101 | ODS HTML CLOSE; *Turn html results viewer off; 102 | 103 | /**************/ 104 | /* fit models */ 105 | /**************/ 106 | 107 | /* Genotype as random effect */ 108 | proc mixed data=a; 109 | class rep block gen; 110 | model y = rep /ddfm=kr; 111 | random gen rep*block; 112 | ods output Covparms=Covparms; * obtain estimated variance components; 113 | run; 114 | 115 | data Covparms_no_gen; 116 | set Covparms; 117 | if Covparm = "gen" then delete; 118 | run; 119 | 120 | /* Genotype as fixed effect */ 121 | proc mixed data=a; 122 | class rep block gen; 123 | model y = gen rep /ddfm=kr; 124 | random rep*block; 125 | lsmeans gen /pdiff; 126 | parms /pdata=Covparms_no_gen noiter; * fixed variance components estimated in model above for better comparability; 127 | ods output Diffs=Diffs; * obtain pairwise differences table; 128 | run; 129 | 130 | /*****************/ 131 | /* H2 estimation */ 132 | /*****************/ 133 | %H2_piepho(ENTRY_NAME=gen, COVPARMS=Covparms, DIFFS=Diffs, OUTPUT=H2_piepho); 134 | 135 | ods html; *Turn html results viewer on; 136 | 137 | /* Show results */ 138 | title "Ad hoc H2 'Piepho'"; 139 | proc print data=H2_piepho label; 140 | run; 141 | 142 | 143 | 144 | 145 | 146 | -------------------------------------------------------------------------------- /Alternative Heritability Measures/SAS/MACROS getC22g getGFD getGamma.sas: -------------------------------------------------------------------------------- 1 | /************************************************************************************************ 2 | _ ___ ___ ___ _ ___ ___ ___ 3 | __ _ ___| |_ / __|_ )_ ) __ _ _ _ __| | / __|_ )_ )__ _ 4 | / _` / -_) _| | (__ / / / / / _` | ' \/ _` | | (__ / / / // _` | 5 | \__, \___|\__| \___/___/___| \__,_|_||_\__,_| \___/___/___\__, | 6 | |___/ |___/ 7 | ************************************************************************************************/ 8 | %MACRO getC22g(ENTRY_NAME=, MMEQSOL=, SOLUTIONF=, OUT_C22=xm_c22, OUT_C22g=xm_C22g); 9 | /* Reduce ODS Output to numeric matrix */ 10 | /***************************************/ 11 | 12 | /* Obtain starting row/column of C22 with respect to C */ 13 | DATA xm_max; 14 | SET &SOLUTIONF.; 15 | xm_n=_n_; 16 | KEEP xm_n; 17 | RUN; 18 | PROC MEANS DATA=xm_max NOPRINT; 19 | VAR xm_n; 20 | OUTPUT max=xm_max OUT=xm_max; 21 | RUN; 22 | DATA xm_max; 23 | SET xm_max; 24 | CALL SYMPUT ("X",xm_max); 25 | RUN; 26 | %LET x=%SYSEVALF(&x+1); 27 | 28 | /* C22.g */ 29 | PROC MEANS DATA=&MMEQSOL. NOPRINT; 30 | WHERE Effect="&ENTRY_NAME."; 31 | VAR row; 32 | OUTPUT OUT=xm_temp; 33 | RUN; 34 | DATA xm_temp; SET xm_temp; /* Create variables &min., &max., &colmax. and &colmin. */ 35 | CALL SYMPUT(CATS("Col",_STAT_),CATS("Col",Row)); 36 | CALL SYMPUT( _STAT_ , Row); 37 | RUN; 38 | DATA &OUT_C22g.; /* Drop most unwanted rows and columns of C */ 39 | SET &MMEQSOL.; 40 | if row<&min. then delete; 41 | if row>&max. then delete; 42 | KEEP &colmin.-&colmax.; 43 | RUN; 44 | 45 | /* C22 */ 46 | PROC MEANS DATA=&MMEQSOL. NOPRINT; 47 | VAR row; 48 | OUTPUT OUT=xm_temp2; 49 | RUN; 50 | DATA xm_temp2; SET xm_temp2; /* Create variables &min., &max., &colmax. and &colmin. for MMEQSOL */ 51 | CALL SYMPUT(CATS("Col",_STAT_),CATS("Col",Row)); 52 | CALL SYMPUT( _STAT_ , Row); 53 | RUN; 54 | DATA &OUT_C22.; /* Drop most unwanted columns of C */ 55 | SET &MMEQSOL.; 56 | if row<&x. then delete; 57 | KEEP col&x.-&colmax.; 58 | RUN; 59 | 60 | PROC DATASETS LIBRARY=work; 61 | DELETE xm_temp xm_temp2 xm_max ; 62 | RUN; QUIT; 63 | %Mend getc22g; 64 | 65 | /************************************************************************************************ 66 | _ ___ ___ _ ___ 67 | __ _ ___| |_ / __| | __| __ _ _ _ __| | | \ 68 | / _` / -_) _| | (_ |_ | _| / _` | ' \/ _` | | |) | 69 | \__, \___|\__| \___( ) |_| \__,_|_||_\__,_| |___/ 70 | |___/ |/ 71 | ************************************************************************************************/ 72 | %MACRO getGFD (ENTRY_NAME=, G=, OUT_m_g=m_g, OUT_m_f=m_f, OUT_m_d=m_d); 73 | /* Obtain and save dimensions of G in variables &min., &max., &comax. and &colmin. */ 74 | PROC MEANS DATA=&G. NOPRINT; 75 | VAR row; 76 | OUTPUT OUT=xm_temp; 77 | RUN; 78 | DATA xm_temp; SET xm_temp; 79 | CALL SYMPUT(CATS("Col",_STAT_),CATS("Col",Row)); 80 | CALL SYMPUT( _STAT_ , Row); 81 | RUN; 82 | 83 | /* Reduce ODS output to numeric matrix G */ 84 | DATA m_G; 85 | SET &G.; 86 | KEEP &colmin.-&colmax.; 87 | RUN; 88 | 89 | DATA m_f; 90 | SET &G.; 91 | row=_n_; 92 | KEEP &colmin.-&colmax.; 93 | RUN; 94 | 95 | /* Obtain and save dimensions of D (i.e. part of G referring to entry main effect, also referred to as G.g) in variables &min., &max., &comax. and &colmin. */ 96 | PROC MEANS DATA=&G. NOPRINT; 97 | WHERE Effect="&ENTRY_NAME."; 98 | VAR row; OUTPUT OUT=xm_temp; 99 | RUN; 100 | DATA xm_temp; SET xm_temp; /* Save dimensions in variables &min., &max. and &colmin. */ 101 | CALL SYMPUT(CATS("Col",_STAT_),CATS("Col",Row)); 102 | CALL SYMPUT( _STAT_ , Row); 103 | RUN; 104 | 105 | DATA m_f; 106 | SET m_f; 107 | row=_n_; 108 | IF row<&min. THEN DELETE; 109 | IF row>&max. THEN DELETE; 110 | DROP row; 111 | RUN; 112 | 113 | DATA m_d; 114 | SET &G.; 115 | row=_n_; 116 | IF row<&min. THEN DELETE; 117 | IF row>&max. THEN DELETE; 118 | KEEP &colmin.-&colmax.; 119 | RUN; 120 | 121 | %MEND getGFD; 122 | 123 | /************************************************************************************************ 124 | _ ___ 125 | __ _ ___| |_ / __|__ _ _ __ _ __ __ _ 126 | / _` / -_) _| | (_ / _` | ' \| ' \/ _` | 127 | \__, \___|\__| \___\__,_|_|_|_|_|_|_\__,_| 128 | |___/ 129 | ************************************************************************************************/ 130 | %MACRO getGamma(m_C22=xm_C22, m_G=m_g, m_F=m_f, m_D= m_d); 131 | PROC IML; 132 | USE &m_C22.; READ ALL INTO C22; 133 | USE &m_G.; READ ALL INTO G; 134 | USE &m_F.; READ ALL INTO F; 135 | USE &m_D.; READ ALL INTO D; 136 | 137 | M = G-C22; /* (12) See Mclean, Sanders, Stroup (1991) */ 138 | inv_G = inv(G); /* Inverse of G */ 139 | Q = F*inv_G*M*inv_G*t(F); /* (10) Q = F G^-1 M G^-1 F' */ 140 | omega = (D||Q)//(Q||Q); /* (10) Create Omega */ 141 | CALL SVD(u, lambda, v, omega); /* (13) Cholesky Decompostion of omega part I */ 142 | m_gamma = u*DIAG(SQRT(lambda)); /* (13) Cholesky Decompostion of omega part II */ 143 | 144 | CREATE m_gamma FROM m_gamma; APPEND FROM m_gamma; 145 | QUIT; RUN; 146 | %MEND getGamma; 147 | -------------------------------------------------------------------------------- /Alternative Heritability Measures/SAS/MACRO H2_R_Simulated.sas: -------------------------------------------------------------------------------- 1 | /************************************************************************************************/ 2 | /* ___ _ _ _ _ _ _ __ _ ___ */ 3 | /* / __(_)_ __ _ _| |__ _| |_ ___ __| | | || |_ ) __ _ _ _ __| | | _ \ */ 4 | /* \__ \ | ' \ || | / _` | _/ -_) _` | | __ /__| / _` | ' \/ _` | | / */ 5 | /* |___/_|_|_|_\_,_|_\__,_|\__\___\__,_| |_||_| \__,_|_||_\__,_| |_|_\ */ 6 | /* */ 7 | /* This macro computes (i) the measure of heritability as the simulated expected correlation */ 8 | /* of predicted and true genotypic value and (ii) a simulated expected response to selection. */ 9 | /* */ 10 | /* Example application code can be found on https://github.com/PaulSchmidtGit/Heritability */ 11 | /* */ 12 | /* This method is based on */ 13 | /* Piepho, H.-P., and J. Möhring. 2007. Computing heritability and selection response from */ 14 | /* unbalanced plant breeding trials. Genetics 177(3):1881–1888. */ 15 | /* Comments in the code refer to respective equations from this article [i.e. (1), (2) etc.] */ 16 | /* */ 17 | /* Requirements/Input: */ 18 | /* The model that is used to analyze the data beforehand should have a random genotype */ 19 | /* main in order to obtain the estimated variance-covariance matrices of (i) the random */ 20 | /* (genotype) effects and (ii) the genotype BLUPs. Furthermore, the genotype main effect */ 21 | /* must be the first random effect written in the model and there must not be variance */ 22 | /* Note the macro only works if all variance components are non-zero. In case a variance */ 23 | /* component fixed to zero, you can drop the corresponding effect from the model and rerun */ 24 | /* rerun the analysis to produce the required input files. */ 25 | /* */ 26 | /* SAS/STAT SAS/IML */ 27 | /* Dataset 'MMEQSOL' */ 28 | /* MMEQSOL= specifies the MIXED / GLIMMIX ODS output with the solutions of the */ 29 | /* mixed model equations, which requires the MMEQSOL option in the PROC statement. */ 30 | /* Dataset 'G' */ 31 | /* G= specifies the MIXED / GLIMMIX ODS output with the estimated */ 32 | /* variance-covariance matrix of the random effects, which requires the G option */ 33 | /* in the RANDOM statement. */ 34 | /* Dataset 'SOLUTIONF' */ 35 | /* SOLUTIONF= specifies the MIXED / GLIMMIX ODS output with fixed-effects solution */ 36 | /* vector, which requires the S option in the model statement. */ 37 | /* n_sim */ 38 | /* This should be a numeric value defining the number of simulation runs. */ 39 | /* H_OUT & R_OUT */ 40 | /* specifiy the name for the output datasets. */ 41 | /* */ 42 | /* Note that in order to prevent complications due to overwritten data, one should not use */ 43 | /* dataset names starting with "xm_" as some are used in this macro. */ 44 | /* */ 45 | /* Version 02 October 2018 */ 46 | /* */ 47 | /* Written by: Paul Schmidt (Paul.Schmidt@uni-hohenheim.de) */ 48 | /* */ 49 | /************************************************************************************************/ 50 | 51 | %MACRO H2RSim(ENTRY_NAME=, MMEQSOL=, G=, SOLUTIONF=, n_sim=, H_OUT=, R_OUT=); 52 | 53 | /* Run Macros directly from GitHub */ 54 | filename _inbox "%sysfunc(getoption(work))/MACROS getC22g getGFD getGamma.sas"; 55 | proc http method="get" 56 | url="https://raw.githubusercontent.com/PaulSchmidtGit/Heritability/master/Alternative%20Heritability%20Measures/SAS/MACROS%20getC22g%20getGFD%20getGamma.sas" out=_inbox; 57 | run; %Include _inbox; filename _inbox clear; 58 | 59 | /* (i) Extract C22g Matrix "m_c22g" from MMEQSOL */ 60 | %getC22g(ENTRY_NAME=&ENTRY_NAME., MMEQSOL=&MMEQSOL., SOLUTIONF=&SOLUTIONF.); 61 | 62 | /* (ii) Extract Matrices "m_D", "m_F" and "m_G" from G */ 63 | %getGFD(ENTRY_NAME=&ENTRY_NAME., G=&G.); 64 | 65 | /* (iii) Use matrices from above to obatin Gamma "m_Gamma" */ 66 | %getGamma(m_C22=xm_C22, m_G=m_G, m_F=m_F, m_D=m_D); 67 | 68 | PROC IML; 69 | USE m_Gamma; READ ALL INTO gamma; 70 | n = nrow(gamma); /* n = number of rows in gamma */ 71 | z = j(n,1,0); /* z = vector with n rows, full of 0s */ 72 | r2=0; a=0; b=0; c=0; /* Predefine r2[correlation g-g_hat], a[Cov g-g_hat], b[Var_g] and c[Var g_hat] as 0 */ 73 | sim_max = &n_sim.; /* sim_max = number of simulations */ 74 | sel_mean = j(n/2,1,0); /* sel_mean = vector half the size of gamma full of 0s */ 75 | 76 | DO sim=1 TO sim_max; 77 | DO i=1 TO n; 78 | z[i]=normal(sim); /* replace 0s in z with standard normally distributed random numbers. Seed=-1 */ 79 | END; 80 | w = gamma*z; /* (14) Multiply decomposed Omega (i.e. gamma) with standard normally distributed random numbers (i.e. z) to create simulated vector w */ 81 | g = w[1:n/2]; /* g = true genetic value = upper half of w */ 82 | g_hat = w[n/2+1:n]; /* g_hat = estimated genetic value = lower half of w */ 83 | r_g_hat = rank(g_hat); /* Give ranks to all g_hats */ 84 | v = g_hat||r_g_hat||g; /* Create v by putting estimated genetic value, rank of estimated genetic value and true genetic value next to each other */ 85 | CALL sort(v, {1}, {1}); /* Sort v so that biggest g_hat is on top */ 86 | DO j=1 TO n/2; 87 | sel_mean[j] = sel_mean[j]+sum(v[1:j,3])/j; /* Selection index for all possible numbers of selected genotypes from best 1 to best n */ 88 | END; 89 | g = g-g[:]; 90 | g_hat = g_hat-g_hat[:]; 91 | r2 = r2+ ( t(g_hat)*g )**2/( t(g)*g*t(g_hat)*g_hat ); /* Sum up all Correlations g-g_hat from each simulation */ 92 | a = a+t(g_hat)*g; /* Sum up all Covariances g-g_hat */ 93 | b = b+t(g)*g; /* Sum up all Variances g */ 94 | c = c+t(g_hat)*g_hat; /* Sum up all Variances g_hat */ 95 | END; 96 | 97 | H2_gg =(r2/sim_max); /* Get average Correlations g-g_hat */ 98 | /*H2_gg_b =(a*a/(b*c))*/ /* Get average Correlations g-g_hat (alternative calculation) */ 99 | sel_mean=sel_mean/sim_max; /* Get average Selection Gain/Response to Selection R */ 100 | 101 | CREATE xm_H2_gg VAR {H2_gg /*H2_gg_b*/}; APPEND; 102 | CREATE xm_R VAR {sel_mean}; APPEND; 103 | QUIT; RUN; 104 | 105 | DATA &H_OUT.; 106 | SET xm_H2_gg; 107 | LABEL H2_gg ="H² as r² of (g-g^)" 108 | /*H2_gg_b="H² as r² of (g-g^) [alternative]"*/ ; 109 | FORMAT H2_gg 110 | /*H2_gg_b [alternative]*/ 8.6; 111 | RUN; 112 | 113 | DATA &R_OUT.; 114 | RETAIN n_selected SEL_MEAN; 115 | KEEP n_selected SEL_MEAN; 116 | SET xm_R; 117 | n_selected=_N_; 118 | LABEL n_selected="Number of selected genotypes" 119 | SEL_MEAN="Simulated R"; 120 | FORMAT SEL_MEAN 8.3; 121 | RUN; 122 | 123 | /* Clean up: delete temporary file */ 124 | /***********************************/ 125 | PROC DATASETS LIBRARY=work; 126 | DELETE xm_h2_gg xm_r; 127 | RUN; QUIT; 128 | 129 | %MEND H2RSim; 130 | --------------------------------------------------------------------------------